ivory backend: it aint pretty, but interface backend compiles

gidl.cabal

@@ -25,7 +25,8 @@ library
                        Gidl.Backend.Ivory,
                        Gidl.Backend.Ivory.Interface,
                        Gidl.Backend.Ivory.Test,
-                       Gidl.Backend.Ivory.Types
+                       Gidl.Backend.Ivory.Types,
+                       Gidl.Backend.Ivory.Unpack
 
   build-depends:       base >=4.7 && <4.8,
                        hashable,

src/Gidl/Backend/Ivory.hs

@@ -5,6 +5,7 @@ import Gidl.Interface
 import Gidl.Backend.Cabal
 import Gidl.Backend.Ivory.Types
 import Gidl.Backend.Ivory.Interface
+import Gidl.Backend.Ivory.Unpack
 
 import Ivory.Artifact
 
@@ -25,7 +26,11 @@ ivoryBackend (TypeEnv te) (InterfaceEnv ie) pkgname namespace_raw =
   imods =[ interfaceModule (namespace ++ ["Interface"]) i
          | (_iname, i) <- ie
          ]
-  sourceMods = tmods ++ imods ++ [ typeUmbrella namespace userDefinedTypes ]
+  sourceMods = tmods
+            ++ imods
+            ++ [ typeUmbrella namespace userDefinedTypes
+               , unpackModule namespace
+               ]
   cf = (defaultCabalFile pkgname cabalmods deps)
   cabalmods = [ filePathToPackage (artifactFileName m) | m <- sourceMods ]
   deps = words "ivory ivory-stdlib ivory-serialize"

src/Gidl/Backend/Ivory/Interface.hs

@@ -21,6 +21,7 @@ interfaceModule modulepath ir =
   stack
     [ text "{-# LANGUAGE DataKinds #-}"
     , text "{-# LANGUAGE RankNTypes #-}"
+    , text "{-# LANGUAGE ScopedTypeVariables #-}"
     , empty
     , text "module"
       <+> im (ifModuleName ir)
@@ -33,18 +34,21 @@ interfaceModule modulepath ir =
     , schemaDoc (ifModuleName ir) (consumerSchema ir)
     ]
   where
-  im mname = mconcat $ punctuate dot
-                     $ map text (modulepath ++ [mname])
-  tm mname = mconcat $ punctuate dot
-                     $ map text (typepath modulepath ++ ["Types", mname])
-    where typepath = reverse . drop 1 . reverse
+  rootpath = reverse . drop 1 . reverse
+  modAt path = mconcat (punctuate dot (map text path))
+  im mname = modAt (modulepath ++ [mname])
+  tm mname = modAt (rootpath modulepath ++ ["Types", mname])
+  unpackMod = modAt (rootpath modulepath ++ ["Unpack"])
 
   typeimports = map (importDecl tm)
               $ nub
               $ map importType
               $ interfaceTypes ir
-  extraimports = [ text "import Ivory.Language"
+
+  extraimports = [ text "import" <+> unpackMod
+                 , text "import Ivory.Language"
                  , text "import Ivory.Serialize"
+                 , text "import Ivory.Stdlib"
                  ]
 
 schemaDoc :: String -> Schema -> Doc
@@ -65,23 +69,96 @@ schemaDoc interfaceName (Schema schemaName schema) = stack
                     <+> text "-> Ivory eff ()")
         | (_, (Message n t)) <- schema
         ]
+    , empty
+    , text (parserName typeName) <+> align
+        (stack [ text ":: forall s0 r b s2 s3 n"
+               , text " . (ANat n)"
+               , text "=>" <+> brackets (text typeName <> text "Handler")
+               , text "-> ConstRef s2 (Array n (Stored Uint8))"
+               , text "-> Ref s3 (Stored Uint32)"
+               , text "-> Ivory ('Effects r b (Scope s0)) ()"
+               ])
+    , text (parserName typeName) <+> text "hs arr offs = do"
+    , indent 2 $ stack
+        [ text "unpackWithCallback arr offs $ \\tag_ref -> do"
+        , indent 2 $ text "tag <- deref tag_ref"
+        , indent 2 $ text "cond_ (map (aux tag) hs)"
+        , text "where"
+        , text "aux :: Uint32"
+        , text "    ->" <+> text typeName <> text "Handler"
+        , text "    -> Cond ('Effects r b (Scope s0)) ()"
+        , stack 
+           [ text "aux ident" <+> parens (text (handlerName n) <+> text "k")
+              <+> equals
+              <+> parens (text "ident ==?" <+> ppr h) <+> text "==>"
+              </> indent 2 callback
+           | (h, Message n t) <- schema
+           , let callback = case t of
+                   PrimType VoidType -> text "k"
+                   _ -> text "unpackWithCallback arr offs k"
+           ]
+        ]
+    , empty
     , text "data" <+> senderConstructor <+> equals <+> senderConstructor
     , indent 2 $ encloseStack lbrace rbrace comma
         [ case t of
             PrimType VoidType -> text (senderName n) <+> colon <> colon
-                <+> text "(forall eff . Ivory eff ())"
+                <+> text "(forall s r b . Ivory ('Effects r b (Scope s)) IBool)"
             _ -> text (senderName n) <+> colon <> colon
-                  <+> parens (text "forall s eff . ConstRef s" 
+                  <+> parens (text "forall s r b s' . ConstRef s'" 
                     <+> parens (text (typeIvoryType t))
-                    <+> text "-> Ivory eff ()")
+                    <+> text "-> Ivory ('Effects r b (Scope s)) IBool")
         | (_, (Message n t)) <- schema
         ]
+    , empty
+    , text (userEnumValueName typeName) <> text "Sender" <+> align
+        (stack [ text ":: forall n s1 s2"
+               , text " . (ANat n)"
+               , text "=> Ref s1 (Array n (Stored Uint8))"
+               , text "-> Ref s2 (Stored Uint32)"
+               , text "->" <+> senderConstructor
+               ])
+    , text (userEnumValueName typeName) <> text "Sender arr offs" <+> equals
+        <+> senderConstructor
+    , indent 2 $ encloseStack lbrace rbrace comma
+        [ case t of
+            PrimType VoidType -> text (senderName n) <+> equals <+> text "do" </> indent 4
+                  (stack [ text "o <- deref offs"
+                         , text "let required_size = sizeOf (Proxy :: Proxy (Stored Uint32))"
+                         , text "    sufficient_space = (o + required_size) <? sizeOf (Proxy :: Proxy (Array n (Stored Uint8)))"
+                         , text "when sufficient_space $ do"
+                         , indent 2 $ stack
+                             [ text "ident <- local (ival (" <+> ppr h <+> text ":: Uint32))"
+                             , text "packInto arr o (constRef ident)"
+                             , text "offs += required_size"
+                             ]
+                         , text "return sufficient_space"
+                         ])
+
+            _ -> text (senderName n) <+> equals <+> text "\\m -> do" </> indent 4
+                  (stack [ text "o <- deref offs"
+                         , text "let required_size = sizeOf (Proxy :: Proxy"
+                             <+> parens (text (typeIvoryType t)) <+> text ")"
+                             <+> text "+ sizeOf (Proxy :: Proxy (Stored Uint32))"
+                         , text "    sufficient_space = (o + required_size) <? sizeOf (Proxy :: Proxy (Array n (Stored Uint8)))"
+                         , text "when sufficient_space $ do"
+                         , indent 2 $ stack
+                             [ text "ident <- local (ival (" <+> ppr h <+> text ":: Uint32))"
+                             , text "packInto arr o (constRef ident)"
+                             , text "packInto arr (o + sizeOf (Proxy :: Proxy (Stored Uint32))) m"
+                             , text "offs += required_size"
+                             ]
+                         , text "return sufficient_space"
+                         ])
+        | (h, (Message n t)) <- schema
+        ]
     ]
   where
-  senderConstructor = text typeName <> text "Sender" 
+  senderConstructor = text typeName <> text "Sender"
   handlerName n = userTypeModuleName n ++ schemaName ++ "Handler"
   senderName n = userEnumValueName n ++ schemaName ++ "Sender"
   typeName = interfaceName ++ schemaName
+  parserName tn = userEnumValueName tn ++ "Parser"
 
 ifModuleName :: Interface -> String
 ifModuleName (Interface iname _ _) = aux iname

src/Gidl/Backend/Ivory/Unpack.hs

@@ -0,0 +1,38 @@
+
+module Gidl.Backend.Ivory.Unpack where
+
+import Data.List (intercalate)
+import Ivory.Artifact
+
+unpackModule :: [String] -> Artifact
+unpackModule modulepath =
+  artifactPath (intercalate "/" modulepath) $
+  artifactString "Unpack.hs" $
+  unlines
+    [ ""
+    , "{-# LANGUAGE DataKinds #-}"
+    , "{-# LANGUAGE RankNTypes #-}"
+    , "{-# LANGUAGE ScopedTypeVariables #-}"
+    , ""
+    , "module " ++ (intercalate "." modulepath) ++ ".Unpack where"
+    , ""
+    , "import Ivory.Language"
+    , "import Ivory.Serialize"
+    , "import Ivory.Stdlib"
+    , ""
+    , "unpackWithCallback :: forall n a s1 s2 r b s0"
+    , "                    . (ANat n, IvorySizeOf a, IvoryArea a, IvoryZero a, Packable a)"
+    , "                   => ConstRef s1 (Array n (Stored Uint8))"
+    , "                   -> Ref s2 (Stored Uint32)"
+    , "                   -> (ConstRef (Stack s0) a -> Ivory ('Effects r b (Scope s0)) ())"
+    , "                   -> Ivory ('Effects r b (Scope s0)) ()"
+    , "unpackWithCallback arr offs k = do"
+    , "  o <- deref offs"
+    , "  let sufficient_remaining = ((o + sizeOf (Proxy :: Proxy a)) <?"
+    , "                               sizeOf (Proxy :: Proxy (Array n (Stored Uint8))))"
+    , "  when sufficient_remaining $ do"
+    , "    v <- local izero"
+    , "    unpackFrom arr o v"
+    , "    k (constRef v)"
+    , "    offs += undefined"
+    ]