tower-backend: test suite now somewhat meaningful

makes sure all the tower code can generate into c, at least.

src/Gidl/Backend/Tower.hs

@@ -12,6 +12,7 @@ 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.Tower.Interface
 
 towerBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
@@ -19,7 +20,7 @@ towerBackend te ie pkgname namespace_raw =
   [ cabalFileArtifact cf
   , makefile
   , defaultconf
-  , artifactPath "tests" (codegenTest namespace)
+  , artifactPath "tests" (codegenTest ie namespace)
   ] ++ map (artifactPath "src") sources
   where
   namespace = dotwords namespace_raw
@@ -41,8 +42,8 @@ towerSources :: InterfaceEnv -> [String] -> [Artifact]
 towerSources (InterfaceEnv ie) namespace = towerInterfaces
   where
   towerInterfaces = concat
-    [ [ interfaceModule (namespace ++ ["Tower", "Interface"]) i (producerSchema i)
-      , interfaceModule (namespace ++ ["Tower", "Interface"]) i (consumerSchema i) ]
+    [ [ interfaceModule (namespace ++ ["Interface"]) i (producerSchema i)
+      , interfaceModule (namespace ++ ["Interface"]) i (consumerSchema i) ]
     | (_iname, i) <- ie ]
 
 makefile :: Artifact
@@ -51,10 +52,33 @@ makefile = artifactCabalFile P.getDataDir "support/tower/Makefile"
 defaultconf :: Artifact
 defaultconf = artifactCabalFile P.getDataDir "support/tower/default.conf"
 
-codegenTest :: [String] -> Artifact
-codegenTest modulepath =
+codegenTest :: InterfaceEnv -> [String] -> Artifact
+codegenTest (InterfaceEnv ie) modulepath =
   artifactCabalFileTemplate P.getDataDir fname
-    [("module_path", intercalate "." modulepath )]
+    [("module_path",intercalate "." modulepath)
+    ,("imports", intercalate "\n"
+                  [ "import "
+                    ++ interfaceImport (ifModuleName i) "Producer"
+                    ++ "\n"
+                    ++ "import "
+                    ++ interfaceImport (ifModuleName i) "Consumer"
+                  | (_, i) <- ie
+                  ])
+    ,("app_body", intercalate "\n  " (concat [ interfaceTest i | (_, i) <- ie ]))
+    ]
   where
   fname = "support/tower/CodeGen.hs.template"
+  interfaceImport i j = intercalate "." (modulepath ++ ["Tower", "Interface", i, j])
 
+  interfaceTest :: Interface -> [String]
+  interfaceTest i = [ schemaTest (producerSchema i)
+                    , schemaTest (consumerSchema i)
+                    ]
+    where
+    schemaTest :: Schema -> String
+    schemaTest (Schema _ []) = []
+    schemaTest (Schema schemaName _)
+      =  (inputFuncName ((ifModuleName i) ++ schemaName))
+      ++ " (snd c) >>= \\i -> "
+      ++ (outputFuncName ((ifModuleName i) ++ schemaName))
+      ++ " i >>= \\(_ :: ChanOutput (Array 80 (Stored Uint8))) -> return ()"

src/Gidl/Backend/Tower/Interface.hs

@@ -34,7 +34,7 @@ interfaceModule modulepath ir schema =
     ]
   where
   (Schema schemaName _) = schema
-  rootpath = reverse . drop 3 . reverse
+  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])
@@ -46,7 +46,8 @@ interfaceModule modulepath ir schema =
               $ map importType
               $ interfaceTypes ir
 
-  extraimports = [ text "import qualified" <+> ivoryIFMod <+> text "as I"
+  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"
@@ -79,7 +80,8 @@ schemaDoc interfaceName (Schema schemaName schema) = stack
                ])
     , text (inputFuncName typeName) <+> text "frame_ch" <+> equals <+> text "do"
     , indent 2 $ stack
-        [ stack [ chanName n <+> text "<- channel"
+        [ towerMonadDependencies
+        , stack [ chanName n <+> text "<- channel"
                 | (_, Message n _) <- schema ]
         , empty
         , text "monitor" <+> dquotes (text (outputFuncName typeName))
@@ -128,7 +130,8 @@ schemaDoc interfaceName (Schema schemaName schema) = stack
                ])
     , text (outputFuncName typeName) <+> text "a" <+> equals <+> text "do"
     , indent 2 $ stack
-        [ text "frame_ch <- channel"
+        [ towerMonadDependencies
+        , text "frame_ch <- channel"
         , text "monitor" <+> dquotes (text (outputFuncName typeName))
             <+> text "$ do"
         , indent 2 $ stack
@@ -145,8 +148,6 @@ schemaDoc interfaceName (Schema schemaName schema) = stack
   constructor = text typeName
   accessorName n = text (userEnumValueName n ++ schemaName)
   typeName = interfaceName ++ schemaName
-  inputFuncName tn = userEnumValueName tn ++ "Input"
-  outputFuncName tn = userEnumValueName tn ++ "Output"
 
   chanName s = text "ch_" <> text s
   emitterName s = text "emitter_" <> text s
@@ -176,3 +177,17 @@ schemaDoc interfaceName (Schema schemaName schema) = stack
         , 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/CodeGen.hs.template

@@ -1,5 +1,9 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DataKinds #-}
+
 module Main where
 
+import Ivory.Language
 import Ivory.Tower
 import Ivory.Tower.Config
 import Ivory.Tower.Compile
@@ -8,6 +12,8 @@ import Ivory.OS.FreeRTOS.Tower.STM32
 import Ivory.Serialize
 import $module_path$.Ivory.Types (typeModules)
 
+$imports$
+
 main :: IO ()
 main = towerCompile p app
   where p topts = do
@@ -16,8 +22,5 @@ main = towerCompile p app
 
 app :: Tower e ()
 app = do
-  towerModule serializeModule
-  mapM_ towerArtifact serializeArtifacts
-  mapM_ towerModule typeModules
-  mapM_ towerDepends typeModules
-
+  (c :: (ChanInput (Array 80 (Stored Uint8)), ChanOutput (Array 80 (Stored Uint8)))) <- channel
+  $app_body$