{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module     : Wayland.Server.Interface
-- Description: Description of the API for an object.
--
-- This module provides data types for describing the requests and events supported by a Wayland object. This is used
-- for marshalling/demarshalling the message using the binary wire protocol.
--
-- In addition, this module provides support for converting interface descriptions into their C equivalents and caching
-- the results (ensuring pointer equality for the same interface).

module Wayland.Server.Interface
  ( -- * Interface Descriptions
    InterfaceDesc(..)
  , MessageDesc(..)
  , ArgumentDesc(..)
  , Nullability(..)
  , -- * Native Interfaces
    InterfaceCache
  , InterfaceCacheState
  , newInterfaceCache
  , destroyInterfaceCache
  , resolveInterface
  ) where

import Control.Monad.State.Strict (MonadState(..), StateT)
import Control.Monad.Trans (MonadIO(..))
import Foreign (Ptr, nullPtr, newArray, new, free, peekArray, Storable(..))
import Foreign.C (newCString)
import qualified Wayland.Server.System as Sys
import qualified Data.Map as M

-- | Description of a Wayland interface and the functionality it provides.
--
-- This is analogous to the wl_interface structure in libwayland and is converted into it as needed.
--
-- An interface can be implemented by an object which is associated with a client.
data InterfaceDesc
  = InterfaceDesc { ifName     :: !String        -- ^ Name of the interface (for example, "wl_output").
                  , ifVersion  :: !Int           -- ^ Version of the interface described in this data structure.
                  , ifRequests :: ![MessageDesc] -- ^ The requests a server should handle to implement the interface.
                  , ifEvents   :: ![MessageDesc] -- ^ The events sent out by a server for instances of the interface.
                  }
  deriving (Show, Eq, Ord)

-- | Description of a message sent between the server and a client (either a request or an event).
--
-- A message operates on an object implementing an interface.
data MessageDesc
  = MessageDesc { msgName              :: !String         -- ^ Name of the protocol message.
                , msgArguments         :: ![ArgumentDesc] -- ^ The argument types passed to the message.
                , msgSince             :: !Int            -- ^ Protocol version where the message was introduced.
                , msgIsDestructor      :: !Bool           -- ^ Indicates whether this is a request to destroy an object.
                }
  deriving (Show, Eq, Ord)

-- | Description of an argument in the signature of a message.
data ArgumentDesc
  = ArgumentInt
  | ArgumentUInt
  | ArgumentFixed
  | ArgumentString !Nullability
  | ArgumentObject !Nullability !InterfaceDesc
  | ArgumentNewID               !InterfaceDesc
  | ArgumentArray
  | ArgumentFD
  deriving (Show, Eq, Ord)

-- | Describes whether a string/object argument in a message is optional.
data Nullability
  = Nullable
  | NotNull
  deriving (Show, Eq, Ord)

-- | State used to cache C interfaces.
--
-- The wl_interface instances are cached so the same interface description always yields the same wl_interface pointer.
newtype InterfaceCache = InterfaceCache (M.Map InterfaceDesc (Ptr Sys.WLInterface))

-- | A state monad providing an instance of 'InterfaceCache'.
type InterfaceCacheState = StateT InterfaceCache IO

-- | Initialize an interface cache.
newInterfaceCache :: IO InterfaceCache
newInterfaceCache = pure $ InterfaceCache M.empty

-- | Destroy an interface cache, freeing all acquired resources.
--
-- This should only be done after no wl_interface instances are referenced as it will free their underlying memory.
destroyInterfaceCache :: InterfaceCache -> IO ()
destroyInterfaceCache (InterfaceCache m) =
  let freeMessage :: Sys.WLMessage -> IO ()
      freeMessage msg = do
        free (Sys.msgName msg)
        free (Sys.msgSignature msg)
        free (Sys.msgTypes msg)
      freeInterface :: Ptr Sys.WLInterface -> IO ()
      freeInterface iface = do
        iface' <- peek iface
        peekArray (fromIntegral (Sys.ifMethodCount iface')) (Sys.ifMethods iface') >>= mapM_ freeMessage
        peekArray (fromIntegral (Sys.ifEventCount iface'))  (Sys.ifEvents iface')  >>= mapM_ freeMessage
        free (Sys.ifName iface')
        free (Sys.ifMethods iface')
        free (Sys.ifEvents iface')
        free iface
  in mapM_ freeInterface m

-- | Resolve a native wl_interface pointer for an interface description.
--
-- This will first attempt to use an existing instance from the 'InterfaceCache'. If there is none, it will create a new
-- native interface and put it in the cache. Resources are freed using 'destroyInterfaceCache'.
--
-- Resolving an interface may also require resolving other interfaces used as arguments, thus this function is
-- implemented recursively.
resolveInterface :: InterfaceDesc -> InterfaceCacheState (Ptr Sys.WLInterface)
resolveInterface i = do
  let mkArgumentType :: ArgumentDesc -> InterfaceCacheState (Ptr Sys.WLInterface)
      mkArgumentType (ArgumentObject _ a) = resolveInterface a
      mkArgumentType (ArgumentNewID a)    = resolveInterface a
      mkArgumentType _                    = pure nullPtr
  let mkArgument :: ArgumentDesc -> String
      mkArgument ArgumentInt                 = "i"
      mkArgument ArgumentUInt                = "u"
      mkArgument ArgumentFixed               = "f"
      mkArgument (ArgumentString NotNull)    = "s"
      mkArgument (ArgumentString Nullable)   = "?s"
      mkArgument (ArgumentObject NotNull _)  = "o"
      mkArgument (ArgumentObject Nullable _) = "?o"
      mkArgument (ArgumentNewID _)           = "n"
      mkArgument ArgumentArray               = "a"
      mkArgument ArgumentFD                  = "h"
  let mkMessage :: MessageDesc -> InterfaceCacheState Sys.WLMessage
      mkMessage m = do
        name      <- liftIO $ newCString (msgName m)
        signature <- liftIO $ newCString (show (msgSince m) ++ (msgArguments m >>= mkArgument))
        types     <- mapM mkArgumentType (msgArguments m) >>= liftIO . newArray
        pure $ Sys.WLMessage { Sys.msgName      = name
                             , Sys.msgSignature = signature
                             , Sys.msgTypes     = types
                             }
  let mkInterface :: InterfaceCacheState (Ptr Sys.WLInterface)
      mkInterface = do
        name    <- liftIO $ newCString (ifName i)
        methods <- mapM mkMessage (ifRequests i) >>= liftIO . newArray
        events  <- mapM mkMessage (ifEvents   i) >>= liftIO . newArray
        liftIO $ new $ Sys.WLInterface { Sys.ifName = name
                                       , Sys.ifVersion = fromIntegral (ifVersion i)
                                       , Sys.ifMethodCount = fromIntegral (length (ifRequests i))
                                       , Sys.ifMethods     = methods
                                       , Sys.ifEventCount  = fromIntegral (length (ifEvents i))
                                       , Sys.ifEvents      = events
                                       }
  InterfaceCache existing <- get
  case M.lookup i existing of
    Just ptr -> pure ptr
    Nothing  -> do ptr <- mkInterface
                   put $ InterfaceCache $ M.insert i ptr existing
                   pure ptr