a draft for the marshaller. still not in use

src/runtime/c/pgf/pgf.h

@@ -77,7 +77,6 @@ typedef struct {
  * a PyObject pointer.
  */
 #ifdef __cplusplus
-typedef struct PgfUnmarshaller PgfUnmarshaller;
 struct PgfUnmarshaller {
     virtual uintptr_t eabs(PgfBindType btype, PgfText *name, uintptr_t body)=0;
     virtual uintptr_t eapp(uintptr_t fun, uintptr_t arg)=0;
@@ -96,6 +95,12 @@ struct PgfUnmarshaller {
     virtual void free_ref(uintptr_t x)=0;
     virtual void free_me()=0;
 };
+
+struct PgfMarshaller {
+    virtual uintptr_t match_lit(PgfUnmarshaller *u, uintptr_t lit)=0;
+    virtual uintptr_t match_expr(PgfUnmarshaller *u, uintptr_t expr)=0;
+    virtual uintptr_t match_type(PgfUnmarshaller *u, uintptr_t *ty)=0;
+};
 #else
 typedef struct PgfUnmarshaller PgfUnmarshaller;
 typedef struct PgfUnmarshallerVtbl PgfUnmarshallerVtbl;
@@ -121,7 +126,19 @@ struct PgfUnmarshallerVtbl {
 struct PgfUnmarshaller {
     PgfUnmarshallerVtbl *vtbl;
 };
+
+typedef struct PgfMarshaller PgfMarshaller;
+typedef struct PgfMarshallerVtbl PgfMarshallerVtbl;
+struct PgfMarshallerVtbl {
+    uintptr_t (*match_lit)(PgfUnmarshaller *u, uintptr_t lit);
+    uintptr_t (*match_expr)(PgfUnmarshaller *u, uintptr_t expr);
+    uintptr_t (*match_type)(PgfUnmarshaller *u, uintptr_t *ty);
+};
+struct PgfMarshaller {
+    PgfMarshallerVtbl *vtbl;
+};
 #endif
+
 typedef float prob_t;
 
 typedef struct PgfPGF PgfPGF;

src/runtime/haskell/PGF2/FFI.hsc

@@ -26,6 +26,7 @@ data PgfItor
 data PgfPGF
 data PgfConcr
 data PgfTypeHypo
+data PgfMarshaller
 data PgfUnmarshaller
 
 foreign import ccall unsafe "pgf_utf8_decode"
@@ -103,6 +104,15 @@ peekText ptr =
                 cs <- decode pptr end
                 return (((toEnum . fromEnum) x) : cs)
 
+newText :: String -> IO (Ptr PgfText)
+newText s = do
+  ptr <- mallocBytes ((#size PgfText) + size + 1)
+  (#poke PgfText, size) ptr (fromIntegral size :: CSize)
+  pokeUtf8CString s (ptr `plusPtr` (#const offsetof(PgfText, text)))
+  return ptr
+  where
+    size = utf8Length s
+
 withText :: String -> (Ptr PgfText -> IO a) -> IO a
 withText s fn =
   allocaBytes ((#size PgfText) + size + 1) $ \ptr -> do
@@ -140,63 +150,99 @@ type CBindType = (#type PgfBindType)
 
 type EAbsFun = Ptr PgfUnmarshaller -> (#type PgfBindType) -> Ptr PgfText -> StablePtr Expr -> IO (StablePtr Expr)
 
+foreign import ccall "dynamic"
+  callEAbsFun :: FunPtr EAbsFun -> EAbsFun
+
 foreign import ccall "wrapper"
   wrapEAbsFun :: EAbsFun -> IO (FunPtr EAbsFun)
 
 type EAppFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Expr -> IO (StablePtr Expr)
 
+foreign import ccall "dynamic"
+  callEAppFun :: FunPtr EAppFun -> EAppFun
+
 foreign import ccall "wrapper"
   wrapEAppFun :: EAppFun -> IO (FunPtr EAppFun)
 
 type ELitFun = Ptr PgfUnmarshaller -> StablePtr Literal -> IO (StablePtr Expr)
 
+foreign import ccall "dynamic"
+  callELitFun :: FunPtr ELitFun -> ELitFun
+
 foreign import ccall "wrapper"
   wrapELitFun :: ELitFun -> IO (FunPtr ELitFun)
 
 type EMetaFun = Ptr PgfUnmarshaller -> (#type PgfMetaId) -> IO (StablePtr Expr)
 
+foreign import ccall "dynamic"
+  callEMetaFun :: FunPtr EMetaFun -> EMetaFun
+
 foreign import ccall "wrapper"
   wrapEMetaFun :: EMetaFun -> IO (FunPtr EMetaFun)
 
 type EFunFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Expr)
 
+foreign import ccall "dynamic"
+  callEFunFun :: FunPtr EFunFun -> EFunFun
+
 foreign import ccall "wrapper"
   wrapEFunFun :: EFunFun -> IO (FunPtr EFunFun)
 
 type EVarFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Expr)
 
+foreign import ccall "dynamic"
+  callEVarFun :: FunPtr EVarFun -> EVarFun
+
 foreign import ccall "wrapper"
   wrapEVarFun :: EVarFun -> IO (FunPtr EVarFun)
 
 type ETypedFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Type -> IO (StablePtr Expr)
 
+foreign import ccall "dynamic"
+  callETypedFun :: FunPtr ETypedFun -> ETypedFun
+
 foreign import ccall "wrapper"
   wrapETypedFun :: ETypedFun -> IO (FunPtr ETypedFun)
 
 type EImplArgFun = Ptr PgfUnmarshaller -> StablePtr Expr -> IO (StablePtr Expr)
 
+foreign import ccall "dynamic"
+  callEImplArgFun :: FunPtr EImplArgFun -> EImplArgFun
+
 foreign import ccall "wrapper"
   wrapEImplArgFun :: EImplArgFun -> IO (FunPtr EImplArgFun)
 
 type LIntFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Literal)
 
+foreign import ccall "dynamic"
+  callLIntFun :: FunPtr LIntFun -> LIntFun
+
 foreign import ccall "wrapper"
   wrapLIntFun :: LIntFun -> IO (FunPtr LIntFun)
 
 type LFltFun = Ptr PgfUnmarshaller -> CDouble -> IO (StablePtr Literal)
 
+foreign import ccall "dynamic"
+  callLFltFun :: FunPtr LFltFun -> LFltFun
+
 foreign import ccall "wrapper"
   wrapLFltFun :: LFltFun -> IO (FunPtr LFltFun)
 
 type LStrFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Literal)
 
+foreign import ccall "dynamic"
+  callLStrFun :: FunPtr LStrFun -> LStrFun
+
 foreign import ccall "wrapper"
   wrapLStrFun :: LStrFun -> IO (FunPtr LStrFun)
 
 type DTypFun = Ptr PgfUnmarshaller -> CInt -> Ptr PgfTypeHypo -> Ptr PgfText -> CInt -> Ptr (StablePtr Expr) -> IO (StablePtr Type)
 
+foreign import ccall "dynamic"
+  callDTypFun :: FunPtr DTypFun -> DTypFun
+
 foreign import ccall "wrapper"
-  wrapTypeFun :: DTypFun -> IO (FunPtr DTypFun)
+  wrapDTypFun :: DTypFun -> IO (FunPtr DTypFun)
 
 foreign import ccall "&hs_free_reference" hs_free_reference :: FunPtr (Ptr PgfUnmarshaller -> StablePtr a -> IO ())
 
@@ -204,6 +250,86 @@ foreign import ccall "&hs_free_unmarshaller" hs_free_unmarshaller :: FunPtr (Ptr
 
 foreign import ccall "hs_free_unmarshaller" freeUnmarshaller :: Ptr PgfUnmarshaller -> IO ()
 
+type MatchFun a = Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr a -> IO (StablePtr a)
+
+foreign import ccall "wrapper"
+  wrapMatchFun :: MatchFun a -> IO (FunPtr (MatchFun a))
+
+mkMarshaller = do
+  vtbl <- mallocBytes (#size PgfMarshallerVtbl)
+  wrapMatchFun matchLit  >>= (#poke PgfMarshallerVtbl, match_lit)  vtbl
+  wrapMatchFun matchExpr >>= (#poke PgfMarshallerVtbl, match_expr) vtbl
+  wrapMatchFun matchType >>= (#poke PgfMarshallerVtbl, match_type) vtbl
+  ptr <- mallocBytes (#size PgfMarshaller)
+  (#poke PgfMarshaller, vtbl) ptr vtbl
+  return ptr
+  where
+    matchLit this u c_lit = do
+      vtbl <- (#peek PgfUnmarshaller, vtbl) u
+      lit <- deRefStablePtr c_lit
+      case lit of
+        LStr s -> do fun <- (#peek PgfUnmarshallerVtbl, lstr) vtbl
+                     c_s <- newText s
+                     callLStrFun fun u c_s
+        LInt n -> do fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl
+                     callLIntFun fun u (fromIntegral n)
+        LFlt d -> do fun <- (#peek PgfUnmarshallerVtbl, lint) vtbl
+                     callLFltFun fun u (realToFrac d)
+
+    matchExpr this u c_expr = do
+      vtbl <- (#peek PgfUnmarshaller, vtbl) u
+      expr <- deRefStablePtr c_expr
+      case expr of
+        EAbs bt var e-> do c_e <- newStablePtr e
+                           fun <- (#peek PgfUnmarshallerVtbl, eabs) vtbl
+                           c_var <- newText var
+                           callEAbsFun fun u (marshalBindType bt) c_var c_e
+        EApp fun arg -> do c_fun <- newStablePtr fun
+                           c_arg <- newStablePtr arg
+                           fun <- (#peek PgfUnmarshallerVtbl, eapp) vtbl
+                           callEAppFun fun u c_fun c_arg
+        ELit lit     -> do c_lit <- newStablePtr lit
+                           fun <- (#peek PgfUnmarshallerVtbl, elit) vtbl
+                           callELitFun fun u c_lit
+        EMeta id     -> do fun <- (#peek PgfUnmarshallerVtbl, emeta) vtbl
+                           callEMetaFun fun u (fromIntegral id)
+        EFun name    -> do fun <- (#peek PgfUnmarshallerVtbl, efun) vtbl
+                           c_name <- newText name
+                           callEFunFun fun u c_name
+        EVar index   -> do fun <- (#peek PgfUnmarshallerVtbl, evar) vtbl
+                           callEVarFun fun u (fromIntegral index)
+        ETyped e ty  -> do c_e  <- newStablePtr e
+                           c_ty <- newStablePtr ty
+                           fun <- (#peek PgfUnmarshallerVtbl, etyped) vtbl
+                           callETypedFun fun u c_e c_ty
+        EImplArg arg -> do c_arg <- newStablePtr arg
+                           fun <- (#peek PgfUnmarshallerVtbl, eimplarg) vtbl
+                           callEImplArgFun fun u c_arg
+
+    matchType this u c_ty = do
+      vtbl <- (#peek PgfUnmarshaller, vtbl) u
+      ty   <- deRefStablePtr c_ty
+      case ty of
+        DTyp hypos cat es -> do fun <- (#peek PgfUnmarshallerVtbl, dtyp) vtbl
+                                let n_hypos = length hypos
+                                c_hypos <- mallocBytes (n_hypos * (#size PgfTypeHypo))
+                                marshalHypos c_hypos hypos
+                                c_cat <- newText cat
+                                c_es <- mapM newStablePtr es >>= newArray
+                                callDTypFun fun u
+                                            (fromIntegral n_hypos)
+                                            c_hypos
+                                            c_cat
+                                            (fromIntegral (length es))
+                                            c_es
+      where
+        marshalHypos _   []               = return ()
+        marshalHypos ptr ((bt,var,ty):hs) = do
+          (#poke PgfTypeHypo, bind_type) ptr (marshalBindType bt)
+          newText var     >>= (#poke PgfTypeHypo, cid)  ptr
+          newStablePtr ty >>= (#poke PgfTypeHypo, type) ptr
+          marshalHypos (ptr `plusPtr` (#size PgfTypeHypo)) hs
+
 mkUnmarshaller = do
   vtbl <- mallocBytes (#size PgfUnmarshallerVtbl)
   wrapEAbsFun     unmarshalEAbs     >>= (#poke PgfUnmarshallerVtbl, eabs)     vtbl
@@ -217,7 +343,7 @@ mkUnmarshaller = do
   wrapLIntFun     unmarshalLInt     >>= (#poke PgfUnmarshallerVtbl, lint)     vtbl
   wrapLFltFun     unmarshalLFlt     >>= (#poke PgfUnmarshallerVtbl, lflt)     vtbl
   wrapLStrFun     unmarshalLStr     >>= (#poke PgfUnmarshallerVtbl, lstr)     vtbl
-  wrapTypeFun     unmarshalType     >>= (#poke PgfUnmarshallerVtbl, dtyp)     vtbl
+  wrapDTypFun     unmarshalDTyp     >>= (#poke PgfUnmarshallerVtbl, dtyp)     vtbl
   (#poke PgfUnmarshallerVtbl, free_ref) vtbl hs_free_reference
   (#poke PgfUnmarshallerVtbl, free_me)  vtbl hs_free_unmarshaller
   ptr <- mallocBytes (#size PgfUnmarshaller)
@@ -268,7 +394,7 @@ mkUnmarshaller = do
       s <- peekText c_v
       newStablePtr (LStr s)
 
-    unmarshalType this n_hypos hypos c_cat n_exprs exprs = do
+    unmarshalDTyp this n_hypos hypos c_cat n_exprs exprs = do
       hypos <- peekHypos n_hypos hypos
       cat <- peekText c_cat
       exprs <- peekExprs n_exprs exprs
@@ -289,6 +415,10 @@ mkUnmarshaller = do
           return (e:es)
 
 
+marshalBindType :: BindType -> (#type PgfBindType)
+marshalBindType Explicit = (#const PGF_BIND_TYPE_EXPLICIT)
+marshalBindType Implicit = (#const PGF_BIND_TYPE_IMPLICIT)
+
 unmarshalBindType :: (#type PgfBindType) -> BindType
 unmarshalBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
 unmarshalBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit