initial commit

1 files changed, 77 insertions, 0 deletions

diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
new file mode 100644
index 0000000..9162d5e
--- /dev/null
+++ b/wayland/Wayland/Server.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Wayland.Server
+  ( Request(..)
+  , ObjectID
+  , Global
+  , DisplayM(..)
+  , Resource(..)
+  , fromRequest
+  , withDisplay
+  , bindSocket
+  , processRequests
+  , flushEvents
+  , sendEvent
+  , destroyResource
+  , registerGlobal
+  , unregisterGlobal
+  ) where
+
+import Data.Typeable (Typeable, cast)
+import Data.Kind (Type)
+import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..))
+import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
+
+data DisplayState
+
+data Global
+
+newtype ObjectID = ObjectID String
+  deriving (Show, Eq, Ord)
+
+class Resource r where
+  type ResourceRequest r :: Type
+  type ResourceEvent   r :: Type
+  objectID :: r -> ObjectID
+
+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 (s, a)
+withDisplay _ _ = undefined
+
+bindSocket :: DisplayM s String
+bindSocket = undefined
+
+processRequests :: (Request -> DisplayM s ()) -> DisplayM s ()
+processRequests _ = undefined
+
+sendEvent :: Resource r => r -> ResourceEvent r -> DisplayM s ()
+sendEvent _ _ = undefined
+
+flushEvents :: DisplayM s ()
+flushEvents = undefined
+
+destroyResource :: Resource r => r -> DisplayM s ()
+destroyResource _ = undefined
+
+registerGlobal :: Resource r => Typeable req => (r -> req) -> DisplayM s Global
+registerGlobal _ = undefined
+
+unregisterGlobal :: Global -> DisplayM s ()
+unregisterGlobal _ = undefined