finish codegen

1 files changed, 119 insertions, 99 deletions

diff --git a/protocols/codegen/Wayland/CodeGen/CodeGen.hs b/protocols/codegen/Wayland/CodeGen/CodeGen.hs
index 517199a..67d02dd 100644
--- a/protocols/codegen/Wayland/CodeGen/CodeGen.hs
+++ b/protocols/codegen/Wayland/CodeGen/CodeGen.hs
@@ -1,7 +1,8 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module Wayland.CodeGen.CodeGen
-  ( generateInterface
+  ( GeneratorConfig(..)
+  , generateInterface
   , generateInterfaceBoot
   ) where
 
@@ -17,7 +18,6 @@ import Data.Functor (($>))
 import Control.Monad.Reader (ReaderT (..), asks)
 import Data.Map ((!))
 import qualified Data.Map as M
-import Data.Maybe (isJust)
 
 newtype Declaration = Declaration { declLines :: [String] }
 data Import = Import { imModule :: !String
@@ -43,14 +43,14 @@ type Generator = ReaderT GeneratorConfig (State GeneratorState)
 
 makeLenses ''GeneratorState
 
-generateInterface :: FlatModules -> TypedProtocol -> TypedInterfaceDesc -> String
-generateInterface flat p i = generate (GeneratorConfig flat p (fst i) (snd i)) emit
+generateInterface :: GeneratorConfig -> String
+generateInterface = generate emit
 
-generateInterfaceBoot :: FlatModules -> TypedProtocol -> TypedInterfaceDesc -> String
-generateInterfaceBoot flat p i = generate (GeneratorConfig flat p (fst i) (snd i)) emitBoot
+generateInterfaceBoot :: GeneratorConfig -> String
+generateInterfaceBoot = generate emitBoot
 
-generate :: GeneratorConfig -> Generator () -> String
-generate cfg g = transform $ runState (runReaderT g cfg) initialState
+generate :: Generator () -> GeneratorConfig -> String
+generate g cfg = transform $ runState (runReaderT g cfg) initialState
   where initialState = GeneratorState { _stateImports       = []
                                       , _stateExports       = []
                                       , _stateExtensions    = []
@@ -92,18 +92,25 @@ resolveInterface (Just name) e = do modules <- asks genModules
                                     resolve (fullModule p (fst i)) e
 resolveInterface Nothing     e = pure e
 
+wrapEnumArray :: String -> EnumDesc -> String
+wrapEnumArray name e = if enumBitfield e then "[" ++ name ++ "]" else name
+
 resolveEnum :: String -> Generator String
 resolveEnum e = resolveQualified $ break (== '.') e
   where resolveQualified :: (String, String) -> Generator String
         resolveQualified (e', [])   = do types <- asks genTypes
-                                         pure $ typeEnums types ! e'
+                                         let EnumName desc name = typeEnums types ! e'
+                                         pure $ wrapEnumArray name desc
         resolveQualified (i,  _:e') = do modules <- asks genModules
-                                         resolveInterface (Just i) $ typeEnums (snd (snd (modules ! i))) ! e'
+                                         let iface = snd (modules ! i)
+                                         let EnumName desc name = typeEnums (snd iface) ! e'
+                                         resolved <- resolveInterface (Just i) name
+                                         pure $ wrapEnumArray resolved desc
 
 resolveArgument :: ArgumentDesc -> Generator String
 resolveArgument a = case argType a of
-                      ArgumentInt    -> maybe (pure "Int")  resolveEnum (argEnum a)
-                      ArgumentUInt   -> maybe (pure "Word") resolveEnum (argEnum a)
+                      ArgumentInt    -> maybe (resolve "Foreign" "Int32")  resolveEnum (argEnum a)
+                      ArgumentUInt   -> maybe (resolve "Foreign" "Word32") resolveEnum (argEnum a)
                       ArgumentFixed  -> pure "Float"
                       ArgumentArray  -> resolve "Data.ByteString" "ByteString"
                       ArgumentFD     -> resolve "System.Posix.Types" "Fd"
@@ -116,23 +123,27 @@ resolveArgument a = case argType a of
 
 emitBoot :: Generator ()
 emitBoot = do
-  anyObject     <- resolve "Wayland.Server" "AnyObject"
-  interfaceDesc <- resolve "Wayland.Server" "InterfaceDesc"
-  objectClass   <- resolve "Wayland.Server" "Object"
-  enumTypes     <- asks $ typeEnums . genTypes
-  i             <- asks genInterface
+  anyObject         <- resolve "Wayland.Server" "AnyObject"
+  interfaceDesc     <- resolve "Wayland.Server" "InterfaceDesc"
+  objectClass       <- resolve "Wayland.Server" "Object"
+  marshallableClass <- resolve "Wayland.Server" "Marshallable"
+  enumTypes         <- asks $ typeEnums . genTypes
+  i                 <- asks genInterface
+  emitExtension "FlexibleInstances"
   emitDecl [ "newtype Object = Object " ++ anyObject ]
   emitExport "Object"
   emitDecl [ "interface :: " ++ interfaceDesc ]
   emitExport "interface"
   emitDecl [ "instance " ++ objectClass ++ " Object"
            , "instance Show Object"
-           , "instance Eq Object" ]
-  let emitEnumBoot e = do let name = enumTypes ! enumName e
+           , "instance Eq Object"
+           , "instance " ++ marshallableClass ++ " Object"
+           , "instance " ++ marshallableClass ++ " (Maybe Object)" ]
+  let emitEnumBoot e = do let EnumName _ name = enumTypes ! enumName e
                           emitDecl [ "data " ++ name
                                    , "instance Show " ++ name
                                    , "instance Eq " ++ name
-                                   , "instance Enum " ++ name ]
+                                   , "instance " ++ marshallableClass ++ " " ++ (if enumBitfield e then "[" ++ name ++ "]" else name) ]
                           emitExport name
   mapM_ emitEnumBoot (ifEnums i)
 
@@ -141,10 +152,12 @@ emit = do
   anyObject     <- resolve "Wayland.Server" "AnyObject"
   hashable      <- resolve "Data.Hashable" "Hashable"
   objectClass   <- resolve "Wayland.Server" "Object"
+  throwError'   <- resolve "Control.Monad.Except" "throwError"
   i             <- asks genInterface
   types         <- asks genTypes
   emitExtension "GeneralizedNewtypeDeriving"
   emitExtension "EmptyDataDeriving"
+  emitExtension "FlexibleInstances"
   emitDecl [ "newtype Object = Object " ++ anyObject
            , "  deriving (Show, Eq, Ord, " ++ hashable ++ ")" ]
   emitExport "Object"
@@ -158,9 +171,9 @@ emit = do
   mapM_ emitArguments (typeEventArgs   types)
   emitExtension "TypeFamilies"
   let matchArgument m msgTypes = case msgTypes ! msgName m of
-                                   ArgumentModeNone       -> ""
-                                   ArgumentModeSingle _   -> " _"
-                                   ArgumentModeRecord _ _ -> " _"
+                                   ArgumentNameNone       -> ""
+                                   ArgumentNameSingle _   -> " _"
+                                   ArgumentNameRecord _ _ -> " _"
   let requestSignature m =
         "  requestSignature _ (Req" ++ pascalCase (msgName m) ++ " _" ++ matchArgument m (typeRequestArgs types) ++ ") = req" ++ pascalCase (msgName m)
   let eventSignature m =
@@ -174,13 +187,23 @@ emit = do
             , "  fromAny = Object"
             , "  describeInterface _ = interface" ]
             ++ demarshalRequests ++
-            [ "  demarshalRequest _ _ = undefined" ]
+            [ "  demarshalRequest o c = " ++ throwError' ++ " $ \"Unknown opcode \" ++ show c ++ \" on \" ++ show o" ]
             ++ marshalEvents ++
             [ "  marshalEvent _ _ = undefined" ]
             ++ fmap requestSignature (ifRequests i) ++
             [ "  requestSignature _ _ = undefined" ]
             ++ fmap eventSignature (ifEvents i) ++
             [ "  eventSignature _ _ = undefined" ])
+  marshallableClass <- resolve "Wayland.Server" "Marshallable"
+  marshal'          <- resolve "Wayland.Server" "marshal"
+  demarshal'        <- resolve "Wayland.Server" "demarshal"
+  emitDecl [ "instance " ++ marshallableClass ++ " Object where"
+           , "  marshal (Object o) = " ++ marshal' ++ " o"
+           , "  demarshal = Object <$> " ++ demarshal' ]
+  emitDecl [ "instance " ++ marshallableClass ++ " (Maybe Object) where"
+           , "  marshal (Just (Object o)) = " ++ marshal' ++ " (Just o)"
+           , "  marshal Nothing           = " ++ marshal' ++ " (Nothing :: Maybe " ++ anyObject ++ ")"
+           , "  demarshal = fmap (Object <$>) " ++ demarshal' ]
 
 requestDescName :: MessageDesc -> String
 requestDescName m = "req" ++ pascalCase (msgName m)
@@ -255,16 +278,16 @@ emitRequests ms = emitMessages ms typeRequestArgs (\m -> requestConstructor m ++
 emitEvents :: [MessageDesc] -> Generator ()
 emitEvents ms = emitMessages ms typeEventArgs eventConstructor "Event"
 
-emitMessages :: [MessageDesc] -> (TypeInfo -> M.Map String ArgumentMode) -> (MessageDesc -> String) -> String -> Generator ()
+emitMessages :: [MessageDesc] -> (TypeInfo -> M.Map String ArgumentName) -> (MessageDesc -> String) -> String -> Generator ()
 emitMessages ms argTypes formatConstructor type' = do
   typeable     <- resolve "Data.Typeable" "Typeable"
   messageClass <- resolve "Wayland.Server" "MessageClass"
   typeClass    <- resolve "Wayland.Server" (type' ++ "Class")
   args         <- asks $ argTypes . genTypes
-  let constructorArg :: ArgumentMode -> Generator String
-      constructorArg ArgumentModeNone         = pure ""
-      constructorArg (ArgumentModeSingle a)   = (++) " " <$> resolveArgument a
-      constructorArg (ArgumentModeRecord _ r) = pure $ " " ++ r
+  let constructorArg :: ArgumentName -> Generator String
+      constructorArg ArgumentNameNone         = pure ""
+      constructorArg (ArgumentNameSingle a)   = (++) " " <$> resolveArgument a
+      constructorArg (ArgumentNameRecord _ r) = pure $ " " ++ r
   let constructor m = (++) (formatConstructor m) <$> constructorArg (args ! msgName m)
   constructors <- mapM constructor ms
   emitDecl $ [ "data " ++ type' ]
@@ -277,73 +300,35 @@ emitMessages ms argTypes formatConstructor type' = do
 demarshalRequest :: MessageDesc -> Generator [String]
 demarshalRequest m = do
   args <- asks $ typeRequestArgs . genTypes
-  let demarshalledValue :: ArgumentDesc -> Generator String
-      demarshalledValue a = case argType a of
-                              ArgumentInt    -> do demarshalInt' <- resolve "Wayland.Server" "demarshalInt"
-                                                   if isJust (argEnum a) then pure $ "(toEnum <$> " ++ demarshalInt' ++ ")"
-                                                                         else pure demarshalInt'
-                              ArgumentUInt   -> do demarshalUInt' <- resolve "Wayland.Server" "demarshalUInt"
-                                                   if isJust (argEnum a) then pure $ "(toEnum . fromIntegral <$> " ++ demarshalUInt' ++ ")"
-                                                                         else pure demarshalUInt'
-                              ArgumentFixed  -> resolve "Wayland.Server" "demarshalFixed"
-                              ArgumentArray  -> resolve "Wayland.Server" "demarshalArray"
-                              ArgumentFD     -> resolve "Wayland.Server" "demarshalFD"
-                              ArgumentString -> if argAllowNull a then resolve "Wayland.Server" "demarshalMaybeString"
-                                                                  else resolve "Wayland.Server" "demarshalString"
-                              ArgumentObject -> if argAllowNull a then resolve "Wayland.Server" "demarshalMaybeObject"
-                                                                  else resolve "Wayland.Server" "demarshalObject"
-                              ArgumentNewID  -> resolve "Wayland.Server" "demarshalNewID"
+  demarshal' <- resolve "Wayland.Server" "demarshal"
   case args ! msgName m of
-    ArgumentModeNone        -> pure [ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = pure $ " ++ requestConstructor m ++ " o" ]
-    ArgumentModeSingle a    -> do val <- demarshalledValue a
-                                  pure [ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = " ++ requestConstructor m ++ " o <$> " ++ val ]
-    ArgumentModeRecord as r -> do vals <- mapM demarshalledValue as
-                                  let demarshal (val, a) = "    " ++ camelCase (argName a) ++ "' <- " ++ val
-                                  let formatArgs []      = [ "      {" ]
-                                      formatArgs (a:as') =  ("      { " ++ recordField r (camelCase (argName a)) ++ " = " ++ camelCase (argName a) ++ "'") : fmap formatArg' as'
-                                      formatArg' a       =   "      , " ++ recordField r (camelCase (argName a)) ++ " = " ++ camelCase (argName a) ++ "'"
+    ArgumentNameNone        -> pure [ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = pure $ " ++ requestConstructor m ++ " o" ]
+    ArgumentNameSingle _    -> do pure [ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = " ++ requestConstructor m ++ " o <$> " ++ demarshal' ]
+    ArgumentNameRecord as r -> do let apply a = "    " ++ camelCase (argName a) ++ "' <- " ++ demarshal'
+                                  let field a = recordField r (camelCase (argName a)) ++ " = " ++ camelCase (argName a) ++ "'"
                                   pure ([ "  demarshalRequest o " ++ show (msgOpCode m) ++ " = do" ]
-                                        ++ fmap demarshal (zip vals as) ++
+                                        ++ fmap apply as ++
                                         [ "    pure $ " ++ requestConstructor m ++ " o $ " ++ r ]
-                                        ++ formatArgs as ++
-                                        [ "      }" ])
+                                        ++ formatBrackets "      {" "      ," "      }" (fmap field as))
 
 marshalEvent :: MessageDesc -> Generator [String]
 marshalEvent m = do
   args <- asks $ typeEventArgs . genTypes
-  let marshalFunc :: ArgumentDesc -> Generator String
-      marshalFunc a = case argType a of
-                        ArgumentInt    -> do marshalInt' <- resolve "Wayland.Server" "marshalInt"
-                                             if isJust (argEnum a) then pure $ "(" ++ marshalInt' ++ " . fromEnum)"
-                                                                   else pure marshalInt'
-                        ArgumentUInt   -> do marshalUInt' <- resolve "Wayland.Server" "marshalUInt"
-                                             if isJust (argEnum a) then pure $ "(" ++ marshalUInt' ++ " . fromIntegral . fromEnum)"
-                                                                   else pure marshalUInt'
-                        ArgumentFixed  -> resolve "Wayland.Server" "marshalFixed"
-                        ArgumentArray  -> resolve "Wayland.Server" "marshalArray"
-                        ArgumentFD     -> resolve "Wayland.Server" "marshalFD"
-                        ArgumentString -> if argAllowNull a then resolve "Wayland.Server" "marshalMaybeString"
-                                                            else resolve "Wayland.Server" "marshalString"
-                        ArgumentObject -> if argAllowNull a then resolve "Wayland.Server" "marshalMaybeObject"
-                                                            else resolve "Wayland.Server" "marshalObject"
-                        ArgumentNewID  -> resolve "Wayland.Server" "marshalNewID"
+  marshal' <- resolve "Wayland.Server" "marshal"
   case args ! msgName m of
-    ArgumentModeNone        -> pure [ "  marshalEvent _ " ++ eventConstructor m ++ " = pure " ++ show (msgOpCode m) ]
-    ArgumentModeSingle a    -> do func <- marshalFunc a
-                                  pure [ "  marshalEvent _ (" ++ eventConstructor m ++ " x) = do"
-                                       , "    " ++ func ++ " x"
+    ArgumentNameNone        -> pure [ "  marshalEvent _ " ++ eventConstructor m ++ " = pure " ++ show (msgOpCode m) ]
+    ArgumentNameSingle _    -> do pure [ "  marshalEvent _ (" ++ eventConstructor m ++ " x) = do"
+                                       , "    " ++ marshal' ++ " x"
                                        , "    pure " ++ show (msgOpCode m) ]
-    ArgumentModeRecord as r -> do funcs <- mapM marshalFunc as
-                                  let apply (func, a) = "    " ++ func ++ " $ " ++ recordField r (camelCase (argName a)) ++ " x"
+    ArgumentNameRecord as r -> do let apply a = "    " ++ marshal' ++ " $ " ++ recordField r (camelCase (argName a)) ++ " x"
                                   pure ([ "  marshalEvent _ (" ++ eventConstructor m ++ " x) = do" ]
-                                        ++ fmap apply (zip funcs as) ++
+                                        ++ fmap apply as ++
                                         [ "    pure " ++ show (msgOpCode m) ])
 
 emitEnum :: EnumDesc -> Generator ()
 emitEnum e = do
-  -- TODO: Handle bitsets
   types <- asks $ typeEnums . genTypes
-  let name = types ! enumName e
+  let EnumName _ name = types ! enumName e
   let constructorName entry = name ++ pascalCase (entryName entry)
   let constructorNames = fmap constructorName (enumEntries e)
   let constructors = dataConstructors constructorNames
@@ -351,30 +336,65 @@ emitEnum e = do
             ++ constructors ++
             [ "  deriving (Show, Eq)" ])
   emitExport $ name ++ "(..)"
-  let fromEnum' (c, i) = "  fromEnum " ++ c ++ " = " ++ show i
-  let toEnum' (c, i) = "  toEnum " ++ show i ++ " = " ++ c
-  let constructorValues = zip constructorNames (fmap entryValue (enumEntries e))
-  emitDecl ([ "instance Enum " ++ name ++ " where" ]
-            ++ fmap toEnum' constructorValues ++
-            [ "  toEnum _ = undefined" ]
-            ++ fmap fromEnum' constructorValues)
+  let values = zip constructorNames (fmap entryValue (enumEntries e))
+  (if enumBitfield e then emitMarshallableBitfield else emitMarshallableEnum) name values
 
-emitArguments :: ArgumentMode -> Generator ()
-emitArguments  ArgumentModeNone              = pure ()
-emitArguments (ArgumentModeSingle _)         = pure ()
-emitArguments (ArgumentModeRecord args name) = do
-  let field a = recordField name (camelCase (argName (fst a))) ++ " :: " ++ snd a
-  let formatArgs []     = [ "    {" ]
-      formatArgs (a:as) =  ("    { " ++ field a) : fmap formatArg' as
-      formatArg' a      =   "    , " ++ field a
+emitMarshallableEnum :: String -> [(String, Int)] -> Generator ()
+emitMarshallableEnum name values = do
+  marshallableClass <- resolve "Wayland.Server" "Marshallable"
+  marshalUInt'      <- resolve "Wayland.Server" "marshalUInt"
+  demarshalUInt'    <- resolve "Wayland.Server" "demarshalUInt"
+  throwError'       <- resolve "Control.Monad.Except" "throwError"
+  let marshal (c, i) = "  marshal " ++ c ++ " = " ++ marshalUInt' ++ " " ++ show i
+  let demarshalCase (c, i) = "      " ++ show i ++ " -> pure " ++ c
+  emitDecl ([ "instance " ++ marshallableClass ++ " " ++ name ++ " where" ]
+            ++ fmap marshal values ++
+            [ "  marshal _ = undefined"
+            , "  demarshal = do"
+            , "    x <- " ++ demarshalUInt'
+            , "    case x of" ]
+            ++ fmap demarshalCase values ++
+            [ "      _ -> " ++ throwError' ++ " $ \"Unknown enum value for type " ++ name ++ ": \" ++ show x" ])
+
+emitMarshallableBitfield :: String -> [(String, Int)] -> Generator ()
+emitMarshallableBitfield name values = do
+  marshallableClass <- resolve "Wayland.Server" "Marshallable"
+  marshalUInt'      <- resolve "Wayland.Server" "marshalUInt"
+  demarshalUInt'    <- resolve "Wayland.Server" "demarshalUInt"
+  catMaybes'        <- resolve "Data.Maybe" "catMaybes"
+  bitOr             <- resolve "Foreign" ".|."
+  bitAnd            <- resolve "Foreign" ".&."
+  let marshalVal (c, i) = "      val " ++ c ++ " = " ++ show i
+  let demarshalVal (c, i) = "val " ++ show i ++ " " ++ c
+  emitDecl ([ "instance " ++ marshallableClass ++ " [" ++ name ++ "] where"
+            , "  marshal = " ++ marshalUInt' ++ " . foldr ((" ++ bitOr ++ ") . val) 0"
+            , "    where" ]
+            ++ fmap marshalVal values ++
+            [ "      val _ = undefined"
+            , "  demarshal = do"
+            , "    x <- " ++ demarshalUInt'
+            , "    let val v v' = if x " ++ bitAnd ++ " v == v then Just v' else Nothing"
+            , "    pure $ " ++ catMaybes' ]
+            ++ formatBrackets "      [" "      ," "      ]" (fmap demarshalVal values))
+
+emitArguments :: ArgumentName -> Generator ()
+emitArguments  ArgumentNameNone              = pure ()
+emitArguments (ArgumentNameSingle _)         = pure ()
+emitArguments (ArgumentNameRecord args name) = do
+  let field (a, aName) = recordField name (camelCase (argName a)) ++ " :: " ++ aName
   resolvedArgs <- mapM resolveArgument args
   emitDecl ([ "data " ++ name
             , "  = " ++ name ]
-            ++ formatArgs (zip args resolvedArgs) ++
-            [ "    }"
-            , "  deriving (Show, Eq)" ])
+            ++ formatBrackets "    {" "    ," "    }" (fmap field (zip args resolvedArgs)) ++
+            [ "  deriving (Show, Eq)" ])
   emitExport $ name ++ "(..)"
 
+formatBrackets :: String -> String -> String -> [String] -> [String]
+formatBrackets open sep close ls = format ls ++ [close]
+  where format []     = [open]
+        format (x:xs) = (open ++ " " ++ x) : fmap format' xs
+        format' x     =  sep  ++ " " ++ x
+
 dataConstructors :: [String] -> [String]
 dataConstructors (c:cs) = ("  = " ++ c) : fmap ("  | " ++) cs
 dataConstructors []     = []