{-# 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 System.Posix.Signals (sigINT)
import qualified Wayland.Protocols.Core.WLOutput as WLOutput
import qualified Data.Map as M
import Data.Time (secondsToDiffTime)

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 CustomMessage
  = MsgBindOutput    Global (NewObject WLOutput.WLOutput)
  | MsgDestroyOutput WLOutput.WLOutput
  | MsgSIGINT        SignalSource
  | MsgTimer         TimerSource
  deriving (Typeable, Show)

instance MessageClass CustomMessage

data Output = Output
  deriving (Show)

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

makeLenses ''State

handleMessage :: Message -> DisplayM State ()
handleMessage m
  | Just (WLOutput.ReqRelease o) <- fromMessage m = destroyObject o
  | Just (MsgBindOutput _ o)     <- fromMessage m = do output <- createObject o MsgDestroyOutput
                                                       outs <- outputs <%= M.insert output Output
                                                       sendEvent output $ WLOutput.EvGeometry geometry
                                                       sendEvent output $ WLOutput.EvDone
                                                       liftIO $ putStrLn $ "Output created, outputs: " ++ show outs
                                                       flushEvents
  | Just (MsgDestroyOutput o)    <- fromMessage m = do outputs %= M.delete o
                                                       liftIO $ putStrLn $ "Output destroyed: " ++ show o
  | Just (MsgSIGINT _)           <- fromMessage m = do c <- interruptedCount <%= (+1)
                                                       liftIO $ putStrLn $ "Received SIGINT " ++ show c ++ "/3"
                                                       when (c >= 3) requestTermination
  | Just (MsgTimer t)            <- fromMessage m = do liftIO $ putStrLn "Timeout passed"
                                                       setTimerSource t $ Just (secondsToDiffTime 2)
  | Just (ClientCreated c)       <- fromMessage m = liftIO $ putStrLn $ "Client created: " ++ show c
  | Just (ClientDestroyed c)     <- fromMessage m = liftIO $ putStrLn $ "Client destroyed: " ++ show c
  | otherwise                                     = pure ()

main :: IO ()
main = void $ withDisplay (State M.empty 0) $ do
  socket <- bindSocket
  liftIO $ putStrLn $ "Listening on socket: " ++ socket
  signal <- registerSignalSource MsgSIGINT sigINT
  timer <- registerTimerSource MsgTimer
  setTimerSource timer $ Just (secondsToDiffTime 1)
  output <- registerGlobal MsgBindOutput
  processMessages handleMessage
  unregisterGlobal output
  unregisterSignalSource signal
  unregisterTimerSource timer