{-# 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  = 5120
                             , WLOutput.physicalHeight = 2880
                             , WLOutput.subpixel       = WLOutput.SubpixelNone
                             , WLOutput.make           = "Apple"
                             , WLOutput.model          = "Studio Display"
                             , WLOutput.transform      = WLOutput.TransformNormal
                             }

data BindRequest
  = BindOutput WLOutput.Handle
  deriving (Typeable, Show)

data SignalRequest
  = ReqSIGINT
  deriving (Typeable, Show)

instance RequestClass SignalRequest
instance RequestClass BindRequest

data Output = Output
  deriving (Show)

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

makeLenses ''State

handleRequest :: Request -> DisplayM State ()
handleRequest r
  | Just (WLOutput.ReqRelease o) <- fromRequest r = do outputs %= M.delete o
                                                       destroyResource o
  | Just (BindOutput o)          <- fromRequest r = do outputs %= M.insert o Output
                                                       sendEvent o $ WLOutput.EvGeometry geometry
                                                       sendEvent o $ WLOutput.EvDone
                                                       flushEvents
  | 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 BindOutput
  processRequests handleRequest
  unregisterGlobal output