{-# LANGUAGE TemplateHaskell #-}

import Wayland.Server
import Lens.Micro.TH (makeLenses)
import Lens.Micro.Mtl ((%=), (<%=))
import Data.Data (Typeable)
import Control.Monad (void, when)
import Control.Monad.Trans (liftIO)
import qualified Wayland.Protocols.Core.WLOutput as WLOutput
import qualified Data.Map as M

geometry :: WLOutput.Geometry
geometry = WLOutput.Geometry { WLOutput.x              = 0
                             , WLOutput.y              = 0
                             , WLOutput.physicalWidth  = 623
                             , WLOutput.physicalHeight = 583
                             , WLOutput.subpixel       = WLOutput.SubpixelNone
                             , WLOutput.make           = "Apple"
                             , WLOutput.model          = "Studio Display"
                             , WLOutput.transform      = WLOutput.TransformNormal
                             }

data CustomRequest
  = ReqBindOutput    (NewObject WLOutput.WLOutput)
  | ReqDestroyOutput WLOutput.WLOutput
  | ReqSIGINT
  deriving (Typeable, Show)

instance RequestClass CustomRequest

data Output = Output
  deriving (Show)

data State = State { _outputs          :: M.Map WLOutput.WLOutput Output
                   , _interruptedCount :: Int
                   }
  deriving (Show)

makeLenses ''State

handleRequest :: Request -> DisplayM State ()
handleRequest r
  | Just (WLOutput.ReqRelease o) <- fromRequest r = destroyObject o
  | Just (ReqBindOutput o)       <- fromRequest r = do output <- createObject o ReqDestroyOutput
                                                       outs <- outputs <%= M.insert output Output
                                                       sendEvent output $ WLOutput.EvGeometry geometry
                                                       sendEvent output $ WLOutput.EvDone
                                                       liftIO $ putStrLn $ "Created output, outputs: " ++ show outs
                                                       flushEvents
  | Just (ReqDestroyOutput o)    <- fromRequest r = outputs %= M.delete o
  | Just ReqSIGINT               <- fromRequest r = do c <- interruptedCount <%= (+1)
                                                       liftIO $ putStrLn $ "Received SIGINT " ++ show c ++ "/3"
                                                       when (c >= 3) requestTermination
  | otherwise                                     = pure ()

main :: IO ()
main = void $ withDisplay (State M.empty 0) $ do
  socket <- bindSocket
  liftIO $ putStrLn $ "Listening on socket: " ++ socket
  _ <- registerSignalEvent ReqSIGINT 2
  output <- registerGlobal ReqBindOutput 4
  processRequests handleRequest
  unregisterGlobal output