{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Wayland.Server
  ( Request(..)
  , ObjectID
  , Global
  , DisplayM(..)
  , ResourceClass(..)
  , RequestClass
  , InterfaceDesc(..)
  , MessageDesc(..)
  , ArgumentDesc(..)
  , Nullability(..)
  , fromRequest
  , withDisplay
  , bindSocket
  , processRequests
  , flushEvents
  , sendEvent
  , destroyResource
  , registerGlobal
  , unregisterGlobal
  , registerSignalEvent
  , requestTermination
  ) where

import Data.Typeable (Typeable, Proxy, cast)
import Data.Kind (Type)
import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT)
import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
import Wayland.Server.System
import Control.Monad.Trans (MonadTrans(..))
import Foreign.C (peekCString)
import Foreign.C.Types (CInt)
import Foreign (nullPtr)
import Data.IORef (IORef, newIORef, writeIORef, readIORef)
import Control.Monad.Reader (ReaderT, MonadReader (..), runReaderT)
import Control.Exception (bracket)
import Data.Functor (($>))

type RequestHandler s = Request -> DisplayM s ()
type EventLoopHandler = Request -> IO ()

data Display
  = Display { display         :: !WLDisplay
            , activeEventLoop :: !(IORef (Maybe EventLoopHandler))
            }

data Global = Global

newtype ObjectID = ObjectID String
  deriving (Show, Eq, Ord)

data Nullability
  = AllowNull
  | NotNull

data ArgumentDesc
  = ArgumentInt
  | ArgumentUInt
  | ArgumentFixed
  | ArgumentString !Nullability
  | ArgumentObject !Nullability
  | ArgumentNewID
  | ArgumentArray
  | ArgumentFD

data MessageDesc
  = MessageDesc { msgName              :: !String
                , msgSignature         :: ![ArgumentDesc]
                , msgSince             :: !Int
                , msgIsDestructor      :: !Bool
                , msgCreatedInterface  :: !(Maybe InterfaceDesc)
                , msgArgumentInterface :: ![InterfaceDesc]
                }

data InterfaceDesc
  = InterfaceDesc { ifName     :: !String
                  , ifVersion  :: !Int
                  , ifRequests :: ![MessageDesc]
                  , ifEvents   :: ![MessageDesc]
                  }

class ResourceClass r where
  type ResourceRequest r :: Type
  type ResourceEvent   r :: Type
  objectID  :: r -> ObjectID
  interface :: Proxy r -> InterfaceDesc

class (Typeable r, Show r) => RequestClass r where

data Request = forall a. RequestClass a => Request a

instance Show Request where
  show (Request r) = show r

newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (ReaderT Display IO) a }
  deriving (Functor, Applicative, Monad, MonadIO, MonadState s)

type instance Zoomed (DisplayM s) = Zoomed (StateT s (ReaderT Display IO))

instance Zoom (DisplayM s) (DisplayM t) s t where
  zoom l (DisplayM m) = DisplayM (zoom l m)

getDisplay :: DisplayM s Display
getDisplay = DisplayM $ lift ask

fromRequest :: Typeable a => Request -> Maybe a
fromRequest (Request x) = cast x

withDisplay :: s -> DisplayM s a -> IO (a, s)
withDisplay initialState f = bracket wlDisplayCreate wlDisplayDestroy $ \sysDisp -> do
  eventLoop <- newIORef Nothing
  let disp = Display { display         = sysDisp
                     , activeEventLoop = eventLoop }
  runReaderT (runStateT (runDisplayM f) initialState) disp

bindSocket :: DisplayM s String
bindSocket = do
  disp <- getDisplay
  name <- liftIO $ wlDisplayAddSocketAuto (display disp)
  liftIO $ peekCString name

processRequests :: RequestHandler s -> DisplayM s ()
processRequests h = do
  disp <- getDisplay
  stateBefore <- get
  stateRef <- liftIO $ newIORef stateBefore
  let handler :: Request -> IO ()
      handler r = do
        s <- readIORef stateRef
        (_, s') <- runReaderT (runStateT (runDisplayM (h r)) s) disp
        writeIORef stateRef s'
        pure ()
  liftIO $ writeIORef (activeEventLoop disp) (Just handler)
  liftIO $ wlDisplayRun (display disp)
  stateAfter <- liftIO $ readIORef stateRef
  put stateAfter

sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
sendEvent _ _ = undefined

flushEvents :: DisplayM s ()
flushEvents = undefined

destroyResource :: ResourceClass r => r -> DisplayM s ()
destroyResource _ = undefined

registerGlobal :: ResourceClass r => RequestClass req => (r -> req) -> DisplayM s Global
registerGlobal _ = pure Global

unregisterGlobal :: Global -> DisplayM s ()
unregisterGlobal _ = pure ()

runRequest :: Display -> Request -> IO ()
runRequest disp r = do
  loop <- readIORef (activeEventLoop disp)
  case loop of
    Just handler -> handler r
    Nothing      -> putStrLn $ "Lost request because no event loop is active: " ++ show r

registerSignalEvent :: RequestClass req => req -> CInt -> DisplayM s ()
registerSignalEvent r sig = do
  disp <- getDisplay
  loop <- liftIO $ wlDisplayGetEventLoop (display disp)
  func <- liftIO $ wrapWLEventLoopSignalFunc $ \_ _ -> runRequest disp (Request r) $> 0
  _ <- liftIO $ wlEventLoopAddSignal loop sig func nullPtr
  pure ()

requestTermination :: DisplayM s ()
requestTermination = do
  disp <- getDisplay
  liftIO $ wlDisplayTerminate (display disp)