gidl: use sequence numbers in get/set attr messages

also i totally changed around the calling convention for backends,
since type env is no longer much use (we generate new types when we
create schemas) and probably a few other minor changes that ripple
through

also we can kill void type now, hooray

src/Gidl.hs

@@ -13,6 +13,7 @@ import Text.Show.Pretty
 
 import Ivory.Artifact
 import Gidl.Parse
+import Gidl.Interface
 import Gidl.Backend.Haskell
 import Gidl.Backend.Ivory
 import Gidl.Backend.Rpc (rpcBackend)
@@ -135,15 +136,14 @@ run = do
       when (debug opts) $ do
         putStrLn (ppShow te)
         putStrLn (ppShow ie)
-      case backend opts of
-        HaskellBackend -> artifactBackend opts $
-          haskellBackend te ie (packagename opts) (namespace opts)
-        IvoryBackend -> artifactBackend opts $
-          ivoryBackend te ie (packagename opts) (namespace opts)
-        TowerBackend -> artifactBackend opts $
-          towerBackend te ie (packagename opts) (namespace opts)
-        RpcBackend -> artifactBackend opts $
-          rpcBackend te ie (packagename opts) (namespace opts)
+      let InterfaceEnv ie' = ie
+          interfaces = map snd ie'
+          b = case backend opts of
+                HaskellBackend -> haskellBackend
+                IvoryBackend -> ivoryBackend
+                TowerBackend -> towerBackend
+                RpcBackend -> rpcBackend
+      artifactBackend opts (b interfaces (packagename opts) (namespace opts))
 
   where
   artifactBackend :: Opts -> [Artifact] -> IO ()

src/Gidl/Backend/Haskell.hs

@@ -1,6 +1,6 @@
 module Gidl.Backend.Haskell where
 
-import Gidl.Types
+import Gidl.Schema
 import Gidl.Interface
 import Gidl.Backend.Cabal
 import Gidl.Backend.Haskell.Types
@@ -10,10 +10,11 @@ import Gidl.Backend.Haskell.Interface
 import Ivory.Artifact
 
 import Data.Char (isSpace)
+import Data.List (nub)
 import Text.PrettyPrint.Mainland
 
-haskellBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
-haskellBackend (TypeEnv te) (InterfaceEnv ie) pkgname namespace_raw =
+haskellBackend :: [Interface] -> String -> String -> [Artifact]
+haskellBackend iis pkgname namespace_raw =
   [ cabalFileArtifact cf
   , makefile
   , artifactPath "tests" serializeTestMod
@@ -21,12 +22,13 @@ haskellBackend (TypeEnv te) (InterfaceEnv ie) pkgname namespace_raw =
   [ artifactPath "src" m | m <- sourceMods
   ]
   where
+  types = nub [ t | i <- iis, t <- interfaceTypes i]
   tmods = [ typeModule False (namespace ++ ["Types"]) t
-          | (_tn, t) <- te
+          | t <- types
           , isUserDefined t
           ]
   imods = [ interfaceModule False (namespace ++ ["Interface"]) i
-          | (_iname, i) <- ie
+          | i <- iis
           ]
   sourceMods = tmods ++ imods
   cf = (defaultCabalFile pkgname cabalmods deps) { tests = [ serializeTest ] }
@@ -35,7 +37,7 @@ haskellBackend (TypeEnv te) (InterfaceEnv ie) pkgname namespace_raw =
 
   serializeTest = defaultCabalTest "serialize-test" "SerializeTest.hs"
                       (pkgname:deps)
-  serializeTestMod = serializeTestModule namespace (map snd ie)
+  serializeTestMod = serializeTestModule namespace iis
 
   namespace = dotwords namespace_raw
 

src/Gidl/Backend/Haskell/Interface.hs

@@ -6,7 +6,7 @@ import Data.Monoid
 import Data.List (intercalate, nub)
 import Data.Char (toUpper)
 
-import Gidl.Types
+import Gidl.Types hiding (typeName)
 import Gidl.Interface
 import Gidl.Schema
 import Gidl.Backend.Haskell.Types
@@ -21,6 +21,7 @@ interfaceModule useAeson modulepath i =
   stack $
     [ text "{-# LANGUAGE DeriveDataTypeable #-}"
     , text "{-# LANGUAGE DeriveGeneric #-}"
+    , text "{-# OPTIONS_GHC -fno-warn-unused-imports #-}"
     , empty
     , text "module"
       <+> im (ifModuleName i)

src/Gidl/Backend/Haskell/Types.hs

@@ -268,6 +268,7 @@ data ImportType = LibraryType String
 
 importType :: Type -> ImportType
 importType (StructType n _) = UserType n
+importType (PrimType (EnumType "bool_t" _ _)) = NoImport
 importType (PrimType (EnumType n _ _)) = UserType n
 importType (PrimType (Newtype n _)) = UserType n
 importType (PrimType (AtomType a)) =

src/Gidl/Backend/Ivory.hs

@@ -4,25 +4,24 @@ import Ivory.Artifact
 import Ivory.Artifact.Template
 
 import Data.Char (isSpace)
-import Data.List (intercalate)
+import Data.List (intercalate, nub)
 
 import qualified Paths_gidl as P
 
-import Gidl.Types
 import Gidl.Interface
 import Gidl.Schema
 import Gidl.Backend.Cabal
 import Gidl.Backend.Ivory.Types
 import Gidl.Backend.Ivory.Schema
 
-ivoryBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
-ivoryBackend te ie pkgname namespace_raw =
+ivoryBackend :: [Interface] -> String -> String -> [Artifact]
+ivoryBackend iis pkgname namespace_raw =
   [ cabalFileArtifact cf
   , artifactPath "tests" $ codegenTest namespace
   , makefile
   ] ++ map (artifactPath "src") sources
   where
-  sources = ivorySources te ie namespace
+  sources = ivorySources iis namespace
   namespace = dotwords namespace_raw
 
   cf = (defaultCabalFile pkgname cabalmods deps) { executables = [ cg_exe ] }
@@ -33,18 +32,18 @@ ivoryBackend te ie pkgname namespace_raw =
 
 
 
-ivorySources :: TypeEnv -> InterfaceEnv -> [String] -> [Artifact]
-ivorySources (TypeEnv te) (InterfaceEnv ie) namespace =
+ivorySources :: [Interface] -> [String] -> [Artifact]
+ivorySources iis namespace =
   tmods ++ concat smods ++ [ typeUmbrella namespace userDefinedTypes
                            , unpackModule namespace
                            ]
   where
-  userDefinedTypes = [ t | (_,t) <- te, isUserDefined t ]
+  userDefinedTypes = nub [ t | i <- iis, t <- interfaceTypes i, isUserDefined t ]
   tmods = [ typeModule (namespace ++ ["Types"]) t
           | t <- userDefinedTypes ]
   smods = [ [ schemaModule (namespace ++ ["Interface"]) i (producerSchema i)
             , schemaModule (namespace ++ ["Interface"]) i (consumerSchema i) ]
-          | (_iname, i) <- ie ]
+          | i <- iis ]
 
 dotwords :: String -> [String]
 dotwords s = case dropWhile isDot s of

src/Gidl/Backend/Ivory/Schema.hs

@@ -6,7 +6,7 @@ import Data.Monoid
 import Data.List (intercalate, nub)
 import Data.Char (toUpper)
 
-import Gidl.Types
+import Gidl.Types hiding (typeName)
 import Gidl.Interface
 import Gidl.Schema
 import Gidl.Backend.Ivory.Types

src/Gidl/Backend/Rpc.hs

@@ -10,12 +10,12 @@ import Gidl.Backend.Haskell.Types
            (typeModule,isUserDefined,typeModuleName,userTypeModuleName
            ,importType,importDecl)
 import Gidl.Interface
-           (Interface(..),InterfaceEnv(..),MethodName,Method(..),Perm(..)
+           (Interface(..),MethodName,Method(..),Perm(..)
            ,interfaceMethods)
 import Gidl.Schema
            (Schema(..),producerSchema,consumerSchema,Message(..)
-           ,consumerMessages)
-import Gidl.Types (Type,TypeEnv(..))
+           ,consumerMessages,interfaceTypes)
+import Gidl.Types (Type)
 
 import Data.Char (isSpace)
 import Data.List (nub)
@@ -31,8 +31,8 @@ import Text.PrettyPrint.Mainland
 
 -- External Interface ----------------------------------------------------------
 
-rpcBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
-rpcBackend (TypeEnv te) (InterfaceEnv ie) pkgName nsStr =
+rpcBackend :: [Interface] -> String -> String -> [Artifact]
+rpcBackend iis pkgName nsStr =
     cabalFileArtifact (defaultCabalFile pkgName modules buildDeps)
   : artifactCabalFile P.getDataDir "support/rpc/Makefile"
   : map (artifactPath "src") sourceMods
@@ -48,14 +48,15 @@ rpcBackend (TypeEnv te) (InterfaceEnv ie) pkgName nsStr =
 
   sourceMods = tmods ++ imods ++ [rpcBaseModule namespace]
 
+  types      = nub [ t | i <- iis, t <- interfaceTypes i]
   tmods      = [ typeModule True (namespace ++ ["Types"]) t
-               | (_tn, t) <- te
+               | t <- types
                , isUserDefined t
                ]
 
   imods      = concat [ [ interfaceModule True (namespace ++ ["Interface"]) i
                         , rpcModule namespace i ]
-                      | (_iname, i) <- ie
+                      | i <- iis
                       ]
 
 

src/Gidl/Backend/Tower.hs

@@ -7,7 +7,6 @@ import Ivory.Artifact.Template
 
 import qualified Paths_gidl as P
 
-import Gidl.Types
 import Gidl.Interface
 import Gidl.Schema
 import Gidl.Backend.Cabal
@@ -16,21 +15,21 @@ import Gidl.Backend.Ivory.Schema (ifModuleName)
 import Gidl.Backend.Tower.Schema
 import Gidl.Backend.Tower.Server
 
-towerBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
-towerBackend te ie pkgname namespace_raw =
+towerBackend :: [Interface] -> String -> String -> [Artifact]
+towerBackend iis pkgname namespace_raw =
   [ cabalFileArtifact cf
   , makefile
   , defaultconf
-  , artifactPath "tests" (codegenTest ie namespace)
+  , artifactPath "tests" (codegenTest iis namespace)
   ] ++ map (artifactPath "src") sources
   where
   namespace = dotwords namespace_raw
 
   sources = isources ++ [ attrModule (namespace ++ ["Tower"]) ] ++ tsources
 
-  tsources = towerSources ie (namespace ++ ["Tower"])
+  tsources = towerSources iis (namespace ++ ["Tower"])
 
-  isources = ivorySources te ie (namespace ++ ["Ivory"])
+  isources = ivorySources iis (namespace ++ ["Ivory"])
 
   cf = (defaultCabalFile pkgname cabalmods deps) { executables = [ cg_exe ] }
   cabalmods = map (filePathToPackage . artifactFileName) sources
@@ -39,8 +38,8 @@ towerBackend te ie pkgname namespace_raw =
             (deps ++ (words "tower-config tower-freertos-stm32") ++ [pkgname])
 
 
-towerSources :: InterfaceEnv -> [String] -> [Artifact]
-towerSources (InterfaceEnv ie) namespace = towerInterfaces
+towerSources :: [Interface] -> [String] -> [Artifact]
+towerSources iis namespace = towerInterfaces
   where
   towerInterfaces = concat
     [ [ schemaModule    ifnamespace i (producerSchema i)
@@ -48,7 +47,7 @@ towerSources (InterfaceEnv ie) namespace = towerInterfaces
       , serverModule    ifnamespace i
       , umbrellaModule  ifnamespace i
       ]
-    | (_iname, i) <- ie ]
+    | i <- iis ]
   ifnamespace = namespace ++ ["Interface"]
 
 makefile :: Artifact
@@ -57,8 +56,8 @@ makefile = artifactCabalFile P.getDataDir "support/tower/Makefile"
 defaultconf :: Artifact
 defaultconf = artifactCabalFile P.getDataDir "support/tower/default.conf"
 
-codegenTest :: InterfaceEnv -> [String] -> Artifact
-codegenTest (InterfaceEnv ie) modulepath =
+codegenTest :: [Interface] -> [String] -> Artifact
+codegenTest iis modulepath =
   artifactCabalFileTemplate P.getDataDir fname
     [("module_path",intercalate "." modulepath)
     ,("imports", intercalate "\n"
@@ -67,9 +66,9 @@ codegenTest (InterfaceEnv ie) modulepath =
                     ++ "\n"
                     ++ "import "
                     ++ interfaceImport (ifModuleName i) "Consumer"
-                  | (_, i) <- ie
+                  | i <- iis
                   ])
-    ,("app_body", intercalate "\n  " (concat [ interfaceTest i | (_, i) <- ie ]))
+    ,("app_body", intercalate "\n  " (concat [ interfaceTest i | i <- iis ]))
     ]
   where
   fname = "support/tower/CodeGen.hs.template"

src/Gidl/Backend/Tower/Schema.hs

@@ -5,7 +5,7 @@ module Gidl.Backend.Tower.Schema where
 import Data.Monoid
 import Data.List (intercalate, nub)
 
-import Gidl.Types
+import Gidl.Types hiding (typeName)
 import Gidl.Interface
 import Gidl.Schema
 import Gidl.Backend.Ivory.Types

src/Gidl/Interface.hs

@@ -4,13 +4,10 @@ module Gidl.Interface
   , lookupInterface
   , insertInterface
   , interfaceParents
-  , interfaceTypes
   , interfaceMethods
   ) where
 
-import Data.List (nub)
 import Gidl.Interface.AST
-import Gidl.Types
 
 lookupInterface :: InterfaceName -> InterfaceEnv -> Maybe Interface
 lookupInterface iname (InterfaceEnv ie) = lookup iname ie
@@ -24,14 +21,6 @@ insertInterface i e@(InterfaceEnv ie) = case lookupInterface iname e of
 interfaceParents :: Interface -> [Interface]
 interfaceParents (Interface _ parents _) = parents
 
-interfaceTypes :: Interface -> [Type]
-interfaceTypes i = nub (map (methodT . snd) ms)
-  where
-  ms = interfaceMethods i
-  methodT :: Method -> Type
-  methodT (AttrMethod _ ty) = ty
-  methodT (StreamMethod _ ty) = ty
-
 interfaceMethods :: Interface -> [(MethodName, Method)]
 interfaceMethods (Interface _ ps ms) = ms ++ concatMap interfaceMethods ps
 

src/Gidl/Schema.hs

@@ -2,6 +2,7 @@
 module Gidl.Schema where
 
 import Data.Word
+import Data.List (nub)
 import Data.Hashable
 import Gidl.Types
 import Gidl.Interface
@@ -12,6 +13,16 @@ data Message = Message String Type
 data Schema = Schema String [(MsgId, Message)]
             deriving (Eq, Show)
 
+-- set of all types required to implement a schema
+schemaTypes :: Schema -> [Type]
+schemaTypes (Schema _ ms) = nub (concat (map aux ms))
+  where aux (_, (Message _ t)) = childTypes t
+
+interfaceTypes :: Interface -> [Type]
+interfaceTypes i = nub (ptypes ++ ctypes)
+  where
+  ptypes = schemaTypes (producerSchema i)
+  ctypes = schemaTypes (consumerSchema i)
 
 producerSchema :: Interface -> Schema
 producerSchema ir = Schema "Producer" [(mkMsgId m, m) | m <- messages ]
@@ -21,9 +32,9 @@ producerSchema ir = Schema "Producer" [(mkMsgId m, m) | m <- messages ]
 producerMessages :: (MethodName,Method) -> [Message]
 producerMessages (streamname, (StreamMethod _ tr)) =
   [ Message streamname tr ]
-producerMessages (_ , (AttrMethod Write _)) = []
-producerMessages (attrname, (AttrMethod  _ tr)) =
-  [ Message (attrname ++ "_val") tr ]
+producerMessages (attrname, (AttrMethod perm tr)) =
+  [ setRequestMessage attrname tr | writable perm ] ++
+  [ getRequestMessage attrname tr | readable perm ]
 
 consumerSchema :: Interface -> Schema
 consumerSchema ir = Schema "Consumer" [(mkMsgId m, m) | m <- messages ]
@@ -32,14 +43,36 @@ consumerSchema ir = Schema "Consumer" [(mkMsgId m, m) | m <- messages ]
 
 consumerMessages :: (MethodName,Method) -> [Message]
 consumerMessages (_, (StreamMethod _ _)) = [] -- XXX eventaully add set rate?
-consumerMessages (attrname, (AttrMethod Write tr)) =
-  [ Message (attrname ++ "_set") tr ]
-consumerMessages (attrname, (AttrMethod Read _)) =
-  [ Message (attrname ++ "_get")  (PrimType VoidType) ]
-consumerMessages (attrname, (AttrMethod ReadWrite tr)) =
-  [ Message (attrname ++ "_set") tr
-  , Message (attrname ++ "_get") (PrimType VoidType)
-  ]
+consumerMessages (attrname, (AttrMethod perm tr)) =
+  [ setResponseMessage attrname tr | writable perm ] ++
+  [ getResponseMessage attrname tr | readable perm ]
+
+readable :: Perm -> Bool
+readable Read = True
+readable ReadWrite = True
+readable _ = False
+
+writable :: Perm -> Bool
+writable Write = True
+writable ReadWrite = True
+writable _ = False
+
+setRequestMessage :: MethodName -> Type -> Message
+setRequestMessage n t = Message (n ++ "_set_req") (sequenceNumStruct t)
+
+setResponseMessage :: MethodName -> Type -> Message
+setResponseMessage n _ = Message (n ++ "_set_resp") sequence_num_t
+
+getRequestMessage :: MethodName -> Type -> Message
+getRequestMessage n _ = Message (n ++ "_get_req") sequence_num_t
+
+getResponseMessage :: MethodName -> Type -> Message
+getResponseMessage n t = Message (n ++ "_get_resp") (sequenceNumStruct t)
+
+sequenceNumStruct :: Type -> Type
+sequenceNumStruct t = StructType ("sequence_numbered_" ++ (typeName t))
+                          [ ("seqnum", sequence_num_t)
+                          , ("val", t) ]
 
 
 mkMsgId :: Message -> MsgId

src/Gidl/Types.hs

@@ -4,10 +4,13 @@ module Gidl.Types
   , lookupTypeName
   , insertType
   , typeLeaves
+  , childTypes
   , sizeOf
   , basePrimType
+  , typeName
   ) where
 
+import Data.Tuple (swap)
 import Data.List (nub)
 import Gidl.Types.AST
 import Gidl.Types.Base
@@ -22,6 +25,17 @@ lookupTypeName tn te =
   where
   aux (TypeEnv e) = lookup tn e
 
+typeName :: Type -> TypeName
+typeName (StructType n _) = n
+typeName (PrimType (EnumType n _ _)) = n
+typeName (PrimType (Newtype n _)) = n
+typeName (PrimType VoidType) = error "XXX"
+typeName t@(PrimType (AtomType _)) =
+  let TypeEnv bte = baseTypeEnv in
+  case lookup t (map swap bte) of
+    Just n -> n
+    Nothing -> error "impossible: cannot find name for AtomType in baseTypeEnv"
+
 insertType :: TypeName -> Type -> TypeEnv -> TypeEnv
 insertType tn t e@(TypeEnv te) = case lookupTypeName tn e of
   Nothing -> TypeEnv ((tn,t):te)
@@ -32,6 +46,8 @@ typeLeaves (StructType _ s) = nub (map snd s)
 typeLeaves (PrimType (Newtype _ tn)) = [PrimType tn]
 typeLeaves _ = []
 
+childTypes :: Type -> [Type]
+childTypes t = [t] ++ concat (map childTypes (typeLeaves t))
 
 sizeOf :: Type -> Integer
 sizeOf (StructType _ s) = sum [ sizeOf tr | (_, tr) <- s ]

src/Gidl/Types/Base.hs

@@ -11,6 +11,7 @@ module Gidl.Types.Base
   , bool_t
   , float_t
   , double_t
+  , sequence_num_t
   , baseTypeEnv
   ) where
 
@@ -43,6 +44,9 @@ float_t = PrimType (AtomType AtomFloat)
 double_t :: Type
 double_t = PrimType (AtomType AtomDouble)
 
+sequence_num_t :: Type
+sequence_num_t = PrimType (Newtype "sequence_num_t" (AtomType (AtomWord Bits32)))
+
 baseTypeEnv :: TypeEnv
 baseTypeEnv = TypeEnv
   [ ( "uint8_t" , uint8_t)
@@ -56,5 +60,6 @@ baseTypeEnv = TypeEnv
   , ( "bool_t"  , bool_t)
   , ( "float_t" , float_t)
   , ( "double_t", double_t)
+  , ( "sequence_num_t", sequence_num_t)
   ]