gidl: interface repr, schemas, void

gidl.cabal

@@ -13,11 +13,13 @@ library
                        Gidl.Parse,
                        Gidl.Interface,
                        Gidl.Interface.AST,
+                       Gidl.Schema,
                        Gidl.Types,
                        Gidl.Types.AST,
                        Gidl.Types.Base
 
   build-depends:       base >=4.7 && <4.8,
+                       hashable,
                        parsec,
                        transformers
   hs-source-dirs:      src

src/Gidl/Interface.hs

@@ -1,10 +1,14 @@
 
 module Gidl.Interface
   ( module Gidl.Interface.AST
+  , InterfaceDescr
+  , InterfaceRepr
+  , interfaceDescrToRepr
   , lookupInterface
   , insertInterface
-  , interfaceTypes
   , interfaceParents
+  , interfaceTypes
+  , interfaceMethods
   ) where
 
 import Data.List (nub)
@@ -12,20 +16,21 @@ import Data.Maybe (fromJust)
 import Gidl.Interface.AST
 import Gidl.Types
 
-lookupInterface :: InterfaceName -> InterfaceEnv -> Maybe Interface
+type InterfaceDescr = Interface InterfaceName TypeName
+
+lookupInterface :: InterfaceName -> InterfaceEnv -> Maybe InterfaceDescr
 lookupInterface iname (InterfaceEnv ie) = lookup iname ie
 
-insertInterface :: InterfaceName -> Interface -> InterfaceEnv -> InterfaceEnv
+insertInterface :: InterfaceName -> InterfaceDescr -> InterfaceEnv -> InterfaceEnv
 insertInterface iname i e@(InterfaceEnv ie) = case lookupInterface iname e of
   Nothing -> InterfaceEnv ((iname,i):ie)
   Just _ -> error ("insertInterface invariant broken: interface " ++ iname ++ "already exists")
 
-interfaceParents :: Interface -> [InterfaceName]
+interfaceParents :: Interface i t -> [i]
 interfaceParents (Interface parents _) = parents
 
 interfaceTypes :: InterfaceName -> InterfaceEnv -> TypeEnv -> [TypeName]
-interfaceTypes iname ie te = nub $
-  concatMap aux ms 
+interfaceTypes iname ie te = nub (concatMap aux ms)
   where
   (Interface _ ms) = fromJust (lookupInterface iname ie)
   aux = typeLeaves
@@ -33,8 +38,29 @@ interfaceTypes iname ie te = nub $
       . (\tn -> lookupTypeName tn te)
       . methodTN
       . snd
-  methodTN :: Method -> TypeName
+  methodTN :: Method TypeName -> TypeName
   methodTN (AttrMethod _ tn) = tn
   methodTN (StreamMethod _ tn) = tn
 
 
+data InterfaceRepr = InterfaceRepr InterfaceName (Interface InterfaceRepr TypeRepr)
+                     deriving (Eq, Show)
+
+interfaceDescrToRepr :: InterfaceName -> InterfaceEnv -> TypeEnv -> InterfaceRepr
+interfaceDescrToRepr iname ie te = InterfaceRepr iname ir
+  where
+  ir = case fromJust $ lookupInterface iname ie of
+      Interface is ms -> Interface (map recur is)
+                           [ (mn, methodDescrToRepr te md) | (mn, md) <- ms ]
+  recur i = interfaceDescrToRepr i ie te
+
+
+methodDescrToRepr :: TypeEnv -> Method TypeName -> Method TypeRepr
+methodDescrToRepr te (AttrMethod p tn) = AttrMethod p (typeDescrToRepr tn te)
+methodDescrToRepr te (StreamMethod r tn) = StreamMethod r (typeDescrToRepr tn te)
+
+interfaceMethods :: InterfaceRepr -> [(MethodName, Method TypeRepr)]
+interfaceMethods ir = ms ++ concatMap interfaceMethods ps
+  where
+  (InterfaceRepr _ (Interface ps ms)) =  ir
+

src/Gidl/Interface/AST.hs

@@ -4,7 +4,7 @@ module Gidl.Interface.AST where
 import Gidl.Types.AST
 
 data InterfaceEnv
-  = InterfaceEnv [(InterfaceName, Interface)]
+  = InterfaceEnv [(InterfaceName, Interface InterfaceName TypeName)]
   deriving (Eq, Show)
 
 emptyInterfaceEnv :: InterfaceEnv
@@ -13,13 +13,13 @@ emptyInterfaceEnv = InterfaceEnv []
 type InterfaceName = String
 type MethodName = String
 
-data Interface
-  = Interface [InterfaceName] [(MethodName, Method)]
+data Interface i t
+  = Interface [i] [(MethodName, Method t)]
   deriving (Eq, Show)
 
-data Method
-  = AttrMethod Perm TypeName
-  | StreamMethod Integer TypeName
+data Method t
+  = AttrMethod Perm t
+  | StreamMethod Integer t
   deriving (Eq, Show)
 
 data Perm

src/Gidl/Parse.hs

@@ -122,7 +122,7 @@ defineType (tn, t) = do
     Just _ -> fail ("type named '" ++ tn ++ "' already exists")
     Nothing -> setTypeEnv (insertType tn t te)
 
-defineInterface :: (InterfaceName, Interface) -> Parser ParseEnv ()
+defineInterface :: (InterfaceName, InterfaceDescr) -> Parser ParseEnv ()
 defineInterface (ina, i) = do
   ie <- getInterfaceEnv
   case lookupInterface ina ie of
@@ -175,7 +175,7 @@ tPermission = do
     "rw"        -> return ReadWrite
     _           -> fail "expected permission"
 
-tInterfaceMethod :: Parser ParseEnv (MethodName, Method)
+tInterfaceMethod :: Parser ParseEnv (MethodName, Method TypeName)
 tInterfaceMethod = tList $ do
   n <- tSymbol
   m <- choice [ try tAttr, try tStream ]
@@ -204,7 +204,7 @@ tKnownInterfaceName  = do
     Just _ -> return n
     Nothing -> fail ("expected a known interface name, got " ++ n)
 
-tInterfaceDecl :: Parser ParseEnv (InterfaceName, Interface)
+tInterfaceDecl :: Parser ParseEnv (InterfaceName, InterfaceDescr)
 tInterfaceDecl = tList $ do
   tIdentifier "def-interface"
   tWhiteSpace

src/Gidl/Schema.hs

@@ -0,0 +1,44 @@
+
+module Gidl.Schema where
+
+import Data.Word
+import Data.Hashable
+import Gidl.Types
+import Gidl.Interface
+
+type MsgId = Word32
+data Message = Message String TypeRepr
+             deriving (Eq, Show)
+data Schema = Schema [(MsgId, Message)]
+            deriving (Eq, Show)
+
+
+producerSchema :: InterfaceRepr -> Schema
+producerSchema ir = Schema [(mkMsgId m, m) | m <- messages ]
+  where
+  messages = concatMap mkMessages (interfaceMethods ir)
+  mkMessages (streamname, (StreamMethod _ tr)) =
+    [ Message streamname tr ]
+  mkMessages (_ , (AttrMethod Write _)) = []
+  mkMessages (attrname, (AttrMethod  _ tr)) =
+    [ Message (attrname ++ "_val") tr ]
+
+consumerSchema :: InterfaceRepr -> Schema
+consumerSchema ir = Schema [(mkMsgId m, m) | m <- messages ]
+  where
+  messages = concatMap mkMessages (interfaceMethods ir)
+
+  mkMessages (_, (StreamMethod _ _)) = [] -- XXX eventaully add set rate?
+  mkMessages (attrname, (AttrMethod Write tr)) =
+    [ Message (attrname ++ "_set") tr ]
+  mkMessages (attrname, (AttrMethod Read _)) =
+    [ Message (attrname ++ "_get") voidTypeRepr ]
+  mkMessages (attrname, (AttrMethod ReadWrite tr)) =
+    [ Message (attrname ++ "_set") tr
+    , Message (attrname ++ "_get") voidTypeRepr
+    ]
+
+
+mkMsgId :: Message -> MsgId
+mkMsgId = fromIntegral . hash . show
+

src/Gidl/Types.hs

@@ -8,6 +8,7 @@ module Gidl.Types
   , typeLeaves
   , typeDescrToRepr
   , sizeOf
+  , voidTypeRepr
   ) where
 
 import Data.List (nub)
@@ -35,12 +36,16 @@ typeLeaves (StructType (Struct s)) = nub (map snd s)
 typeLeaves (NewtypeType (Newtype tn)) = [tn]
 typeLeaves (EnumType _) = []
 typeLeaves (AtomType _) = []
+typeLeaves VoidType = []
 
 
 type TypeDescr = Type TypeName
 data TypeRepr = TypeRepr TypeName (Type TypeRepr)
                 deriving (Eq, Show)
 
+voidTypeRepr :: TypeRepr
+voidTypeRepr = TypeRepr "void" VoidType
+
 -- invariant: TypeName exists in a well-formed TypeEnv
 typeDescrToRepr :: TypeName -> TypeEnv -> TypeRepr
 typeDescrToRepr tn te = TypeRepr tn tr
@@ -52,6 +57,7 @@ typeDescrToRepr tn te = TypeRepr tn tr
           NewtypeType (Newtype (typeDescrToRepr ntn te))
         StructType (Struct s) ->
           StructType (Struct [(i, typeDescrToRepr stn te) | (i, stn) <- s])
+        VoidType -> VoidType
 
 
 sizeOf :: TypeRepr -> Integer
@@ -62,6 +68,7 @@ sizeOf (TypeRepr _ (AtomType (AtomInt bs))) = bitsSize bs
 sizeOf (TypeRepr _ (AtomType (AtomWord bs))) = bitsSize bs
 sizeOf (TypeRepr _ (AtomType AtomFloat)) = 4
 sizeOf (TypeRepr _ (AtomType AtomDouble)) = 8
+sizeOf (TypeRepr _ VoidType) = 0
 
 bitsSize :: Bits -> Integer
 bitsSize Bits8  = 1

src/Gidl/Types/AST.hs

@@ -16,6 +16,7 @@ data Type t
   | NewtypeType (Newtype t)
   | EnumType EnumT
   | AtomType Atom
+  | VoidType
   deriving (Eq, Show)
 
 data Atom

tests/Test.hs

@@ -4,6 +4,7 @@ import Control.Monad
 import Gidl.Types
 import Gidl.Interface
 import Gidl.Parse
+import Gidl.Schema
 
 main :: IO ()
 main = test "tests/testtypes.sexpr"
@@ -26,3 +27,8 @@ test f = do
         putStrLn (iname ++ ":")
         print (interfaceTypes iname ie te)
         print (interfaceParents i)
+        putStrLn "---"
+        let ir = interfaceDescrToRepr iname ie te
+        print (producerSchema ir)
+        print (consumerSchema ir)
+        putStrLn "---"