Merge branch 'master' of github.com:aisamanra/gidl

.travis.yml

@@ -1,6 +1,4 @@
 language: haskell
-
-
 before_install:
   - sudo add-apt-repository -y ppa:terry.guo/gcc-arm-embedded
   - sudo apt-get update -qq
@@ -12,6 +10,7 @@ before_install:
   - git clone https://github.com/galoisinc/ivory-tower-stm32
   - export BSP_REPO=$PWD/ivory-tower-stm32
 install:
+  - cabal install cabal-install
   - cabal install alex
   - cabal install happy
 script:

README.md

@@ -5,13 +5,23 @@ describing structured types.
 
 ## IDL format
 
-See example in tests/example.idl.
+See example in tests/example.idl. Currently, the format is not set in stone -
+revisions coming shortly.
 
-## Backend
+## Backends
 
-Gidl currently has a native Haskell backend. Ivory language backend coming soon.
+Gidl currently has backends for:
+  - Native Haskell
+  - [Ivory][] language
+  - [Tower][] wrapper over Ivory
 
-## Tests
+## Build and Test
+Use the `create-sandbox` target in the Makefile to create a local cabal
+sandbox and install all dependencies.
 
-Use the `test` target in the Makefile to generate and test a Haskell library
-for the IDL file.
+The default target builds the gidl library. You can then use `cabal run gidl --
+<OPTIONS>` to run the code generator. Use the `--help` option to get usage
+information.
+
+Use the `test` target in the Makefile to generate and test each backend
+implementation.

gidl.cabal

@@ -11,6 +11,9 @@ cabal-version:       >=1.10
 data-files: support/ivory/Unpack.hs.template,
             support/ivory/CodeGen.hs.template,
             support/ivory/Makefile,
+            support/tower/CodeGen.hs.template,
+            support/tower/Attr.hs.template,
+            support/tower/default.conf,
             support/tower/Makefile
 
 library
@@ -28,10 +31,11 @@ library
                        Gidl.Backend.Haskell.Test,
                        Gidl.Backend.Haskell.Types,
                        Gidl.Backend.Ivory,
-                       Gidl.Backend.Ivory.Interface,
+                       Gidl.Backend.Ivory.Schema,
                        Gidl.Backend.Ivory.Test,
                        Gidl.Backend.Ivory.Types,
                        Gidl.Backend.Tower,
+                       Gidl.Backend.Tower.Schema,
                        Gidl.Backend.Tower.Interface
 
   other-modules:       Paths_gidl

src/Gidl/Backend/Ivory.hs

@@ -13,7 +13,7 @@ import Gidl.Interface
 import Gidl.Schema
 import Gidl.Backend.Cabal
 import Gidl.Backend.Ivory.Types
-import Gidl.Backend.Ivory.Interface
+import Gidl.Backend.Ivory.Schema
 
 ivoryBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
 ivoryBackend te ie pkgname namespace_raw =
@@ -35,15 +35,15 @@ ivoryBackend te ie pkgname namespace_raw =
 
 ivorySources :: TypeEnv -> InterfaceEnv -> [String] -> [Artifact]
 ivorySources (TypeEnv te) (InterfaceEnv ie) namespace =
-  tmods ++ concat imods ++ [ typeUmbrella namespace userDefinedTypes
+  tmods ++ concat smods ++ [ typeUmbrella namespace userDefinedTypes
                            , unpackModule namespace
                            ]
   where
   userDefinedTypes = [ t | (_,t) <- te, isUserDefined t ]
   tmods = [ typeModule (namespace ++ ["Types"]) t
           | t <- userDefinedTypes ]
-  imods = [ [ interfaceModule (namespace ++ ["Interface"]) i (producerSchema i)
-            , interfaceModule (namespace ++ ["Interface"]) i (consumerSchema i) ]
+  smods = [ [ schemaModule (namespace ++ ["Interface"]) i (producerSchema i)
+            , schemaModule (namespace ++ ["Interface"]) i (consumerSchema i) ]
           | (_iname, i) <- ie ]
 
 dotwords :: String -> [String]

src/Gidl/Backend/Ivory/Interface.hs

@@ -1,5 +1,5 @@
 
-module Gidl.Backend.Ivory.Interface where
+module Gidl.Backend.Ivory.Schema where
 
 
 import Data.Monoid
@@ -13,8 +13,8 @@ import Gidl.Backend.Ivory.Types
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 
-interfaceModule :: [String] -> Interface -> Schema -> Artifact
-interfaceModule modulepath ir schema =
+schemaModule :: [String] -> Interface -> Schema -> Artifact
+schemaModule modulepath ir schema =
   artifactPath (intercalate "/" (modulepath ++ [ifModuleName ir])) $
   artifactText (schemaName ++ ".hs") $
   prettyLazyText 80 $

src/Gidl/Backend/Ivory/Test.hs

@@ -5,7 +5,7 @@ module Gidl.Backend.Ivory.Test where
 import Data.Monoid
 import Gidl.Interface
 import Gidl.Schema
-import Gidl.Backend.Ivory.Interface
+import Gidl.Backend.Ivory.Schema
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 

src/Gidl/Backend/Tower.hs

@@ -12,7 +12,8 @@ import Gidl.Interface
 import Gidl.Schema
 import Gidl.Backend.Cabal
 import Gidl.Backend.Ivory (dotwords, ivorySources)
-import Gidl.Backend.Ivory.Interface (ifModuleName)
+import Gidl.Backend.Ivory.Schema (ifModuleName)
+import Gidl.Backend.Tower.Schema
 import Gidl.Backend.Tower.Interface
 
 towerBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
@@ -25,7 +26,7 @@ towerBackend te ie pkgname namespace_raw =
   where
   namespace = dotwords namespace_raw
 
-  sources = isources ++ tsources
+  sources = isources ++ [ attrModule (namespace ++ ["Tower"]) ] ++ tsources
 
   tsources = towerSources ie (namespace ++ ["Tower"])
 
@@ -42,9 +43,12 @@ towerSources :: InterfaceEnv -> [String] -> [Artifact]
 towerSources (InterfaceEnv ie) namespace = towerInterfaces
   where
   towerInterfaces = concat
-    [ [ interfaceModule (namespace ++ ["Interface"]) i (producerSchema i)
-      , interfaceModule (namespace ++ ["Interface"]) i (consumerSchema i) ]
+    [ [ schemaModule    ifnamespace i (producerSchema i)
+      , schemaModule    ifnamespace i (consumerSchema i)
+      , interfaceModule ifnamespace i
+      ]
     | (_iname, i) <- ie ]
+  ifnamespace = namespace ++ ["Interface"]
 
 makefile :: Artifact
 makefile = artifactCabalFile P.getDataDir "support/tower/Makefile"
@@ -82,3 +86,12 @@ codegenTest (InterfaceEnv ie) modulepath =
       ++ " (snd c) >>= \\i -> "
       ++ (outputFuncName ((ifModuleName i) ++ schemaName))
       ++ " i >>= \\(_ :: ChanOutput (Array 80 (Stored Uint8))) -> return ()"
+
+
+attrModule :: [String] -> Artifact
+attrModule modulepath =
+  artifactPath (intercalate "/" modulepath) $
+  artifactCabalFileTemplate P.getDataDir fname
+    [("module_path", intercalate "." modulepath )]
+  where
+  fname = "support/tower/Attr.hs.template"

src/Gidl/Backend/Tower/Interface.hs

@@ -3,191 +3,188 @@ module Gidl.Backend.Tower.Interface where
 
 
 import Data.Monoid
-import Data.List (intercalate, nub)
+import Data.List (intercalate)
 
-import Gidl.Types
 import Gidl.Interface
 import Gidl.Schema
 import Gidl.Backend.Ivory.Types
-import Gidl.Backend.Ivory.Interface (ifModuleName, parserName, senderName)
+import Gidl.Backend.Ivory.Schema (ifModuleName)
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 
-interfaceModule :: [String] -> Interface -> Schema -> Artifact
-interfaceModule modulepath ir schema =
-  artifactPath (intercalate "/" (modulepath ++ [ifModuleName ir])) $
-  artifactText (schemaName ++ ".hs") $
+interfaceModule :: [String] -> Interface -> Artifact
+interfaceModule modulepath i =
+  artifactPath (intercalate "/" modulepath) $
+  artifactText (ifModuleName i ++ ".hs") $
   prettyLazyText 80 $
   stack
     [ text "{-# LANGUAGE DataKinds #-}"
     , text "{-# LANGUAGE RankNTypes #-}"
     , text "{-# LANGUAGE ScopedTypeVariables #-}"
+    , text "{-# LANGUAGE KindSignatures #-}"
+    , text "{-# LANGUAGE RecordWildCards #-}"
     , text "{-# OPTIONS_GHC -fno-warn-unused-imports #-}"
+    , text "{-# OPTIONS_GHC -fno-warn-unused-matches #-}"
     , empty
     , text "module"
-      <+> im (ifModuleName ir) <> dot <> text schemaName
+      <+> im (ifModuleName i)
       <+> text "where"
     , empty
-    , stack $ typeimports ++ extraimports
+    , stack imports
     , empty
-    , schemaDoc (ifModuleName ir) schema
+    , attrsDataType i
+    , empty
+    , attrsTowerConstructor i
+    , empty
+    , attrsInitializer i
+    , empty
+    , streamsDataType i
+    , empty
+    , streamsTowerConstructor i
+    , empty
+    , interfaceServer i
     ]
   where
-  (Schema schemaName _) = schema
   rootpath = reverse . drop 2 . reverse
   modAt path = mconcat (punctuate dot (map text path))
   im mname = modAt (modulepath ++ [mname])
-  tm mname = modAt (rootpath modulepath ++ ["Ivory","Types", mname])
-  ivoryIFMod = modAt (rootpath modulepath
-                      ++ ["Ivory","Interface", ifModuleName ir, schemaName])
-
-  typeimports = map (importDecl tm)
-              $ nub
-              $ map importType
-              $ interfaceTypes ir
-
-  extraimports = [ text "import" <+> modAt (rootpath modulepath ++ ["Ivory", "Types"])
-                 , text "import qualified" <+> ivoryIFMod <+> text "as I"
-                 , text "import Ivory.Language"
-                 , text "import Ivory.Stdlib"
-                 , text "import Ivory.Tower"
-                 , text "import Ivory.Serialize"
-                 ]
-
-schemaDoc :: String -> Schema -> Doc
-schemaDoc interfaceName (Schema schemaName [])     =
-    text "-- Cannot define" <+> text schemaName  <+> text "schema for"
-        <+> text interfaceName <+> text "interface: schema is empty"
-schemaDoc interfaceName (Schema schemaName schema) = stack
-    [ text "-- Define" <+> text schemaName  <+> text "schema for"
-        <+> text interfaceName <+> text "interface"
-    , empty
-    , text "data" <+> constructor <+> text "c" <+> equals <+> constructor
-    , indent 2 $ encloseStack lbrace rbrace comma
-        [ case t of
-            PrimType VoidType -> accessorName n <+> colon <> colon
-                <+> text "c (Stored IBool)"
-            _ -> accessorName n <+> colon <> colon
-                    <+> text "c"
-                    <+> parens (text (typeIvoryType t))
-        | (_, (Message n t)) <- schema
-        ]
-    , empty
-    , text (inputFuncName typeName) <+> align
-        (stack [ text ":: (ANat n)"
-               , text "=> ChanOutput (Array n (Stored Uint8))"
-               , text "-> Tower e" <+> parens (constructor <+> text "ChanOutput")
-               ])
-    , text (inputFuncName typeName) <+> text "frame_ch" <+> equals <+> text "do"
-    , indent 2 $ stack
-        [ towerMonadDependencies
-        , stack [ chanName n <+> text "<- channel"
-                | (_, Message n _) <- schema ]
-        , empty
-        , text "monitor" <+> dquotes (text (outputFuncName typeName))
-            <+> text "$ do"
-        , indent 2 $ stack
-            [ text "handler frame_ch \"parse_frame\" $ do" 
-            , indent 2 $ stack
-                [ stack [ emitterName n <+> text "<- emitter"
-                           <+> parens (text "fst" <+> chanName n)
-                           <+> text "1"
-                        | (_, Message n _) <- schema
-                        ]
-                , text "callback $ \\f -> do"
-                , indent 2 $ stack
-                    [ text "offs <- local izero"
-                    , text "_ <- I." <> text (parserName typeName)
-                        <+> text "f offs $ I." <> constructor
-                    , indent 2 $ encloseStack lbrace rbrace comma
-                        [ case t of
-                            PrimType VoidType ->
-                                 text "I." <> accessorName n <+> equals
-                                  <+> text "emitV" <+> emitterName n
-                                  <+> text "true >> return true"
-                            _ -> text "I." <> accessorName n <+> equals
-                                  <+> text "\\v -> emit" <+> emitterName n
-                                  <+> text "v >> return true"
-                        | (_, Message n t) <- schema
-                        ]
-                    , text "return ()"
-                    ]
-                ]
-
-            ]
-        , empty
-        , text "return" <+> constructor <+> encloseStack lbrace rbrace comma
-            [ accessorName n <+> equals
-              <+> parens (text "snd" <+> chanName n)
-            | (_, Message n _) <- schema
-            ]
-        ]
-    , empty
-    , text (outputFuncName typeName) <> align
-        (stack [ text ":: (ANat n)"
-               , text "=>" <+> constructor <+> text "ChanOutput"
-               , text "-> Tower e (ChanOutput (Array n (Stored Uint8)))"
-               ])
-    , text (outputFuncName typeName) <+> text "a" <+> equals <+> text "do"
-    , indent 2 $ stack
-        [ towerMonadDependencies
-        , text "frame_ch <- channel"
-        , text "monitor" <+> dquotes (text (outputFuncName typeName))
-            <+> text "$ do"
-        , indent 2 $ stack
-            [ text "handler" <+> parens (accessorName n <+> text "a")
-                <+> dquotes (accessorName n) <+> text "$ do"
-                </> indent 2 (parseEmitBody n t)
-                </> empty
-            | (_, Message n t) <- schema
-            ]
-        , text "return (snd frame_ch)"
-        ]
+
+  imports =
+    [ text "import" <+> modAt (rootpath modulepath ++ ["Tower", "Attr"])
+    , text "import" <+> im (ifModuleName i) <> dot <> text "Producer"
+    , text "import" <+> im (ifModuleName i) <> dot <> text "Consumer"
+    , text "import Ivory.Language"
+    , text "import Ivory.Tower"
     ]
+
+
+attrsDataType :: Interface -> Doc
+attrsDataType i = text "data" <+> constructor <+> text "(p :: Area * -> *) ="
+               </> indent 2 constructor
+               </> indent 4 body
+  where
+  constructor = text (ifModuleName i) <> text "Attrs"
+  body = encloseStack lbrace rbrace comma
+    [ text n <+> colon <> colon <+> text "p"
+                 <+> parens (text (typeIvoryType t))
+    | (aname, AttrMethod _ t)  <- interfaceMethods i
+    , let n = userEnumValueName aname
+    ]
+
+attrsTowerConstructor :: Interface -> Doc
+attrsTowerConstructor i = typesig </> decl </> indent 2 body </> indent 2 ret
   where
-  constructor = text typeName
-  accessorName n = text (userEnumValueName n ++ schemaName)
-  typeName = interfaceName ++ schemaName
-
-  chanName s = text "ch_" <> text s
-  emitterName s = text "emitter_" <> text s
-
-  parseEmitBody n (PrimType VoidType) = stack
-    [ text "e <- emitter (fst frame_ch) 1"
-    , text "callback $ \\_ -> do"
-    , indent 2 $ stack
-        [ text "f <- local izero"
-        , text "o <- local izero"
-        , text "ok <-" <+> text "I." <> accessorName n
-            <+> parens (text "I." <> text (senderName typeName)
-                        <+> text "f o")
-        , text "ifte_ ok (emit e (constRef f)) (return ())"
-        ]
+  constructor = text (ifModuleName i) <> text "Attrs"
+  typesig = text "tower" <> constructor <+> colon <> colon
+    <+> constructor <+> text "Init"
+    <+> text "->"
+    <+> text "Tower e" <+> parens (constructor <+> text "Attr")
+  decl = text "tower" <> constructor <+> text "ivals = do"
+  body = stack
+    [ text n <> text "_p <- towerAttr"
+       <+> dquotes (text aname)
+       <+> parens (text n <+> text "ivals")
+    | (aname, AttrMethod _ _)  <- interfaceMethods i
+    , let n = userEnumValueName aname
     ]
-  parseEmitBody n _ = stack
-    [ text "e <- emitter (fst frame_ch) 1"
-    , text "callback $ \\w -> do"
-    , indent 2 $ stack
-        [ text "f <- local izero"
-        , text "o <- local izero"
-        , text "ok <-" <+> text "I." <> accessorName n
-            <+> parens (text "I." <> text (senderName typeName)
-                        <+> text "f o")
-            <+> text "w"
-        , text "ifte_ ok (emit e (constRef f)) (return ())"
-        ]
+  ret = text "return" <+> constructor <+> encloseStack lbrace rbrace comma
+    [ text n <+> equals <+> text n <> text "_p"
+    | (aname, AttrMethod _ _)  <- interfaceMethods i
+    , let n = userEnumValueName aname
     ]
 
-  towerMonadDependencies = stack
-    [ text "towerModule serializeModule"
-    , text "mapM_ towerArtifact serializeArtifacts"
-    , text "mapM_ towerModule typeModules"
-    , text "mapM_ towerDepends typeModules"
-    , empty
+attrsInitializer :: Interface -> Doc
+attrsInitializer i = typesig </> decl </> indent 2 body
+  where
+  constructor = text (ifModuleName i) <> text "Attrs"
+  typesig = text "init" <> constructor <+> colon <> colon
+            <+> constructor <+> text "Init"
+  decl = text "init" <> constructor <+> equals <+> constructor
+  body = encloseStack lbrace rbrace comma
+    [ text n <+> equals <+> text "izero"
+    | (aname, AttrMethod _ _)  <- interfaceMethods i
+    , let n = userEnumValueName aname
     ]
 
-inputFuncName :: String -> String
-inputFuncName tn = userEnumValueName tn ++ "Input"
+streamsDataType :: Interface -> Doc
+streamsDataType i = text "data" <+> constructor <+> text "(p :: Area * -> *) ="
+               </> indent 2 constructor
+               </> indent 4 body
+  where
+  constructor = text (ifModuleName i) <> text "Streams"
+  body = encloseStack lbrace rbrace comma
+    [ text n <+> colon <> colon <+> text "p"
+                 <+> parens (text (typeIvoryType t))
+    | (aname, StreamMethod _ t)  <- interfaceMethods i
+    , let n = userEnumValueName aname
+    ]
+
+streamsTowerConstructor :: Interface -> Doc
+streamsTowerConstructor i = typesig </> decl </> indent 2 body </> indent 2 ret
+  where
+  constructor = text (ifModuleName i) <> text "Streams"
+  typesig = text "tower" <> constructor <+> colon <> colon
+    <+> text "Tower e"
+    <+> parens (constructor <+> text "ChanInput" <> comma
+                <+> constructor <+> text "ChanOutput")
+  decl = text "tower" <> constructor <+> text "= do"
+  body = stack
+    [ text n <> text "_c <- channel"
+    | (aname, StreamMethod _ _)  <- interfaceMethods i
+    , let n = userEnumValueName aname
+    ]
+  ret = text "return" <+> encloseStack lparen rparen comma
+    [ mkstream "fst", mkstream "snd"]
+  mkstream acc = constructor </> indent 2 (encloseStack lbrace rbrace comma
+    [ text n <+> equals <+> text acc <+> text n <> text "_c"
+    | (aname, StreamMethod _ _)  <- interfaceMethods i
+    , let n = userEnumValueName aname
+    ])
+
+
+interfaceServer :: Interface -> Doc
+interfaceServer i =
+  stack [typedef, decl, indent 2 body, indent 2 ret]
+  where
+  constructor postfix = text (ifModuleName i) <> text postfix
+  fname =  text "tower" <> constructor "Server"
+  typedef = fname <+> align (stack
+      [ guardEmptySchema (consumerSchema i)
+                         (text "::" <+> constructor "Consumer")
+                         (text ":: -- no consumer schema")
+      , guardEmptySchema (consumerSchema i) (text "->") (text "  ")
+            <+> constructor "Attrs Attr"
+      , text "->" <+> constructor "Streams ChanOutput"
+      , text "->" <+> text "Tower e"
+             <+> guardEmptySchema (producerSchema i)
+                                  (constructor "Producer")
+                                  (text "()")
+      ])
+  decl = fname <+> guardEmptySchema (consumerSchema i)
+                                    (constructor "Consumer{..}")
+                                    empty
+               <+> constructor "Attrs{..}"
+               <+> constructor "Streams{..}"
+               <+> equals <+> text "do"
+  body = stack [ methodBody (text (userEnumValueName n)) m
+               | (n,m) <- interfaceMethods i ]
+  ret = text "return" <+> guardEmptySchema (producerSchema i)
+                                           (constructor "Producer{..}")
+                                           (text "()")
+
+  methodBody n (StreamMethod _ _) =
+    text "let" <+> n <> text "Producer" <+> equals <+> n
+  methodBody n (AttrMethod Read _) =
+    n <> text "ValProducer" <+> text "<- readableAttrServer"
+      <+> n <+> n <> text "GetConsumer"
+  methodBody n (AttrMethod Write _) =
+    text "writableAttrServer" <+> n <+> n <> text "SetConsumer"
+  methodBody n (AttrMethod ReadWrite _) =
+    n <> text "ValProducer" <+> text "<- readwritableAttrServer"
+      <+> n <+> n <> text "GetConsumer" <+> n <> text "SetConsumer"
+
+
+guardEmptySchema :: Schema -> Doc -> Doc -> Doc
+guardEmptySchema (Schema _ []) _ d = d
+guardEmptySchema (Schema _ _) d _ = d
 
-outputFuncName :: String -> String
-outputFuncName tn = userEnumValueName tn ++ "Output"

src/Gidl/Backend/Tower/Schema.hs

@@ -0,0 +1,192 @@
+
+module Gidl.Backend.Tower.Schema where
+
+
+import Data.Monoid
+import Data.List (intercalate, nub)
+
+import Gidl.Types
+import Gidl.Interface
+import Gidl.Schema
+import Gidl.Backend.Ivory.Types
+import Gidl.Backend.Ivory.Schema (ifModuleName, parserName, senderName)
+import Ivory.Artifact
+import Text.PrettyPrint.Mainland
+
+schemaModule :: [String] -> Interface -> Schema -> Artifact
+schemaModule modulepath ir schema =
+  artifactPath (intercalate "/" (modulepath ++ [ifModuleName ir])) $
+  artifactText (schemaName ++ ".hs") $
+  prettyLazyText 80 $
+  stack
+    [ text "{-# LANGUAGE DataKinds #-}"
+    , text "{-# LANGUAGE RankNTypes #-}"
+    , text "{-# LANGUAGE ScopedTypeVariables #-}"
+    , text "{-# OPTIONS_GHC -fno-warn-unused-imports #-}"
+    , empty
+    , text "module"
+      <+> im (ifModuleName ir) <> dot <> text schemaName
+      <+> text "where"
+    , empty
+    , stack $ typeimports ++ extraimports
+    , empty
+    , schemaDoc (ifModuleName ir) schema
+    ]
+  where
+  (Schema schemaName _) = schema
+  rootpath = reverse . drop 2 . reverse
+  modAt path = mconcat (punctuate dot (map text path))
+  im mname = modAt (modulepath ++ [mname])
+  tm mname = modAt (rootpath modulepath ++ ["Ivory","Types", mname])
+  ivoryIFMod = modAt (rootpath modulepath
+                      ++ ["Ivory","Interface", ifModuleName ir, schemaName])
+
+  typeimports = map (importDecl tm)
+              $ nub
+              $ map importType
+              $ interfaceTypes ir
+
+  extraimports = [ text "import" <+> modAt (rootpath modulepath ++ ["Ivory", "Types"])
+                 , text "import qualified" <+> ivoryIFMod <+> text "as I"
+                 , text "import Ivory.Language"
+                 , text "import Ivory.Stdlib"
+                 , text "import Ivory.Tower"
+                 , text "import Ivory.Serialize"
+                 ]
+
+schemaDoc :: String -> Schema -> Doc
+schemaDoc interfaceName (Schema schemaName [])     =
+    text "-- Cannot define" <+> text schemaName  <+> text "schema for"
+        <+> text interfaceName <+> text "interface: schema is empty"
+schemaDoc interfaceName (Schema schemaName schema) = stack
+    [ text "-- Define" <+> text schemaName  <+> text "schema for"
+        <+> text interfaceName <+> text "interface"
+    , empty
+    , text "data" <+> constructor<+> equals <+> constructor
+    , indent 2 $ encloseStack lbrace rbrace comma
+        [ case t of
+            PrimType VoidType -> accessorName n <+> colon <> colon
+                <+> text "ChanOutput (Stored IBool)"
+            _ -> accessorName n <+> colon <> colon
+                <+> text "ChanOutput" <+> parens (text (typeIvoryType t))
+        | (_, (Message n t)) <- schema
+        ]
+    , empty
+    , text (inputFuncName typeName) <+> align
+        (stack [ text ":: (ANat n)"
+               , text "=> ChanOutput (Array n (Stored Uint8))"
+               , text "-> Tower e" <+> constructor
+               ])
+    , text (inputFuncName typeName) <+> text "frame_ch" <+> equals <+> text "do"
+    , indent 2 $ stack
+        [ towerMonadDependencies
+        , stack [ chanName n <+> text "<- channel"
+                | (_, Message n _) <- schema ]
+        , empty
+        , text "monitor" <+> dquotes (text (outputFuncName typeName))
+            <+> text "$ do"
+        , indent 2 $ stack
+            [ text "handler frame_ch \"parse_frame\" $ do" 
+            , indent 2 $ stack
+                [ stack [ emitterName n <+> text "<- emitter"
+                           <+> parens (text "fst" <+> chanName n)
+                           <+> text "1"
+                        | (_, Message n _) <- schema
+                        ]
+                , text "callback $ \\f -> do"
+                , indent 2 $ stack
+                    [ text "offs <- local izero"
+                    , text "_ <- I." <> text (parserName typeName)
+                        <+> text "f offs $ I." <> constructor
+                    , indent 2 $ encloseStack lbrace rbrace comma
+                        [ case t of
+                            PrimType VoidType ->
+                                 text "I." <> accessorName n <+> equals
+                                  <+> text "emitV" <+> emitterName n
+                                  <+> text "true >> return true"
+                            _ -> text "I." <> accessorName n <+> equals
+                                  <+> text "\\v -> emit" <+> emitterName n
+                                  <+> text "v >> return true"
+                        | (_, Message n t) <- schema
+                        ]
+                    , text "return ()"
+                    ]
+                ]
+
+            ]
+        , empty
+        , text "return" <+> constructor <+> encloseStack lbrace rbrace comma
+            [ accessorName n <+> equals
+              <+> parens (text "snd" <+> chanName n)
+            | (_, Message n _) <- schema
+            ]
+        ]
+    , empty
+    , text (outputFuncName typeName) <> align
+        (stack [ text ":: (ANat n)"
+               , text "=>" <+> constructor
+               , text "-> Tower e (ChanOutput (Array n (Stored Uint8)))"
+               ])
+    , text (outputFuncName typeName) <+> text "a" <+> equals <+> text "do"
+    , indent 2 $ stack
+        [ towerMonadDependencies
+        , text "frame_ch <- channel"
+        , text "monitor" <+> dquotes (text (outputFuncName typeName))
+            <+> text "$ do"
+        , indent 2 $ stack
+            [ text "handler" <+> parens (accessorName n <+> text "a")
+                <+> dquotes (accessorName n) <+> text "$ do"
+                </> indent 2 (parseEmitBody n t)
+                </> empty
+            | (_, Message n t) <- schema
+            ]
+        , text "return (snd frame_ch)"
+        ]
+    ]
+  where
+  constructor = text typeName
+  accessorName n = text (userEnumValueName n ++ schemaName)
+  typeName = interfaceName ++ schemaName
+
+  chanName s = text "ch_" <> text s
+  emitterName s = text "emitter_" <> text s
+
+  parseEmitBody n (PrimType VoidType) = stack
+    [ text "e <- emitter (fst frame_ch) 1"
+    , text "callback $ \\_ -> do"
+    , indent 2 $ stack
+        [ text "f <- local izero"
+        , text "o <- local izero"
+        , text "ok <-" <+> text "I." <> accessorName n
+            <+> parens (text "I." <> text (senderName typeName)
+                        <+> text "f o")
+        , text "ifte_ ok (emit e (constRef f)) (return ())"
+        ]
+    ]
+  parseEmitBody n _ = stack
+    [ text "e <- emitter (fst frame_ch) 1"
+    , text "callback $ \\w -> do"
+    , indent 2 $ stack
+        [ text "f <- local izero"
+        , text "o <- local izero"
+        , text "ok <-" <+> text "I." <> accessorName n
+            <+> parens (text "I." <> text (senderName typeName)
+                        <+> text "f o")
+            <+> text "w"
+        , text "ifte_ ok (emit e (constRef f)) (return ())"
+        ]
+    ]
+
+  towerMonadDependencies = stack
+    [ text "towerModule serializeModule"
+    , text "mapM_ towerArtifact serializeArtifacts"
+    , text "mapM_ towerModule typeModules"
+    , text "mapM_ towerDepends typeModules"
+    , empty
+    ]
+
+inputFuncName :: String -> String
+inputFuncName tn = userEnumValueName tn ++ "Input"
+
+outputFuncName :: String -> String
+outputFuncName tn = userEnumValueName tn ++ "Output"

support/tower/Attr.hs.template

@@ -0,0 +1,138 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module $module_path$.Attr where
+
+import Ivory.Language
+import Ivory.Tower
+
+data AttrWriter a =
+  AttrWriter
+    { aw_chan :: ChanInput a
+    , aw_name :: String
+    }
+
+data AttrReader a =
+  AttrReader
+    { ar_chan :: ChanOutput a
+    , ar_name :: String
+    , ar_ival :: Init a
+    }
+
+data Attr a =
+  Attr
+    { attr_writer :: AttrWriter a
+    , attr_reader :: AttrReader a
+    }
+
+attrReaderState :: (IvoryArea a, IvoryZero a)
+                => AttrReader a -> Monitor e (Ref Global a)
+attrReaderState ar@AttrReader{..} = do
+  s <- stateInit ar_name ar_ival
+  attrReaderHandler ar \$ do
+    callback \$ \\v -> refCopy s v
+  return s
+
+attrReaderHandler :: (IvoryArea a, IvoryZero a)
+                  => AttrReader a -> Handler a e () -> Monitor e ()
+attrReaderHandler AttrReader{..} k =
+  handler ar_chan (ar_name ++ "_update") k
+
+attrWriterEmitter :: (IvoryArea a, IvoryZero a) 
+                  => AttrWriter a -> Handler b e (Emitter a)
+attrWriterEmitter AttrWriter{..} = emitter aw_chan 1
+
+towerAttr :: (IvoryArea a) => String -> Init a -> Tower e (Attr a)
+towerAttr n i = do
+  c <- channel
+  return Attr
+    { attr_writer = AttrWriter
+      { aw_chan = fst c
+      , aw_name = n
+      }
+    , attr_reader = AttrReader
+      { ar_chan = snd c
+      , ar_name = n
+      , ar_ival = i
+      }
+    }
+
+class AttrNamed p where
+  attrName :: (IvoryArea a) => p a -> String
+
+instance AttrNamed AttrReader where
+  attrName = ar_name
+
+instance AttrNamed AttrWriter where
+  attrName = aw_name
+
+instance AttrNamed Attr where
+  attrName = attrName . attr_reader
+
+class AttrReadable p where
+  attrState   :: (IvoryArea a, IvoryZero a) => p a -> Monitor e (Ref Global a)
+  attrHandler :: (IvoryArea a, IvoryZero a) => p a -> Handler a e () -> Monitor e ()
+
+instance AttrReadable AttrReader where
+  attrState = attrReaderState
+  attrHandler = attrReaderHandler
+
+instance AttrReadable Attr where
+  attrState = attrReaderState . attr_reader
+  attrHandler p k = attrReaderHandler (attr_reader p) k
+
+class AttrWritable p where
+  attrEmitter :: (IvoryArea a, IvoryZero a) => p a -> Handler b e (Emitter a)
+
+instance AttrWritable AttrWriter where
+  attrEmitter = attrWriterEmitter
+
+instance AttrWritable Attr where
+  attrEmitter = attrWriterEmitter . attr_writer
+
+
+readableAttrServer :: (IvoryArea a, IvoryZero a)
+                   => Attr a
+                   -> ChanOutput (Stored IBool)
+                   -> Tower e (ChanOutput a)
+readableAttrServer p get = do
+  val <- channel
+  monitor (named "Server") \$ do
+    s <- attrState p
+    handler get (named "Get") \$ do
+      e <- emitter (fst val) 1
+      callback \$ const \$ emit e (constRef s)
+  return (snd val)
+  where
+  named n = attrName p ++ n
+
+writableAttrServer :: (IvoryArea a, IvoryZero a)
+                   => Attr a
+                   -> ChanOutput a
+                   -> Tower e ()
+writableAttrServer p set = do
+  monitor (named "Server") \$ do
+    handler set (named "Set") \$ do
+      e <- attrEmitter p
+      callback \$ \\v -> emit e v
+  where
+  named n = attrName p ++ n
+
+readwritableAttrServer :: (IvoryArea a, IvoryZero a)
+                       => Attr a
+                       -> ChanOutput (Stored IBool)
+                       -> ChanOutput a
+                       -> Tower e (ChanOutput a)
+readwritableAttrServer p get set = do
+  val <- channel
+  monitor (named "Server") \$ do
+    s <- attrState p
+    handler set (named "Set") \$ do
+      e <- attrEmitter p
+      callback \$ \\v -> emit e v
+    handler get (named "Get") \$ do
+      e <- emitter (fst val) 1
+      callback \$ const \$ emit e (constRef s)
+  return (snd val)
+  where
+  named n = attrName p ++ n