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

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

import Data.Typeable (Typeable, Proxy, cast)
import Data.Kind (Type)
import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT, gets)
import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
import Wayland.Server.System
import Control.Monad.Trans (MonadTrans(..))
import Foreign.C (peekCString)

data DisplayState
  = DisplayState { display :: WLDisplay
                 }

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

data Request = forall a. Typeable a => Request a

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

type instance Zoomed (DisplayM s) = Zoomed (StateT s (StateT DisplayState IO))

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

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

withDisplay :: s -> DisplayM s a -> IO (a, s)
withDisplay initialState f = do
  disp <- wlDisplayCreate
  let dispState = DisplayState { display = disp }
  (res, _) <-runStateT (runStateT (runDisplayM f) initialState) dispState
  wlDisplayDestroy disp
  return res

bindSocket :: DisplayM s String
bindSocket = do
  disp <- DisplayM $ lift $ gets display
  name <- liftIO $ wlDisplayAddSocketAuto disp
  liftIO $ peekCString name

processRequests :: (Request -> DisplayM s ()) -> DisplayM s ()
processRequests _ = do
  disp <- DisplayM $ lift $ gets display
  liftIO $ wlDisplayRun disp

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 => Typeable req => (r -> req) -> DisplayM s Global
registerGlobal _ = pure Global

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