implemented functionType and marshalling for types and expressions

src/runtime/c/Makefile.am

@@ -16,6 +16,7 @@ libpgf_la_SOURCES = \
 	pgf/reader.cxx \
 	pgf/reader.h \
 	pgf/data.h \
+	pgf/expr.cxx \
 	pgf/expr.h \
 	pgf/namespace.h
 

src/runtime/c/pgf/data.h

@@ -1,9 +1,7 @@
 #ifndef PGF_DATA_H_
 #define PGF_DATA_H_
 
-#include <stdint.h>
 #include <string.h>
-#include <sys/types.h>
 #include <assert.h>
 #include <iostream>
 #include <exception>
@@ -121,9 +119,15 @@ struct PGF_INTERNAL_DECL PgfPGFRoot {
 #pragma GCC diagnostic ignored "-Wattributes"
 
 struct PgfPGF : DB {
-    PGF_INTERNAL_DECL PgfPGF(const char* fpath, int flags, int mode)
-                         : DB(fpath, flags, mode) {};
-    PGF_INTERNAL_DECL ~PgfPGF() {};
+    PGF_INTERNAL_DECL PgfPGF(const char* fpath, int flags, int mode,
+                             PgfUnmarshaller *unmarshaller)
+                         : DB(fpath, flags, mode)
+    { u = unmarshaller; };
+
+    PGF_INTERNAL_DECL ~PgfPGF()
+    { u->free_me(u); };
+
+    PgfUnmarshaller *u;
 };
 
 #pragma GCC diagnostic pop

src/runtime/c/pgf/expr.h

@@ -7,13 +7,6 @@ typedef variant PgfExpr;
 struct PgfHypo;
 struct PgfType;
 
-typedef int PgfMetaId;
-
-typedef enum {
-	PGF_BIND_TYPE_EXPLICIT,
-	PGF_BIND_TYPE_IMPLICIT
-} PgfBindType;
-
 /// A literal for an abstract syntax tree
 typedef variant PgfLiteral;
 
@@ -106,4 +99,13 @@ typedef struct {
 	PgfExpr expr;
 } PgfExprProb;
 
+PGF_INTERNAL_DECL
+uintptr_t pgf_unmarshall_literal(PgfUnmarshaller *u, PgfLiteral l);
+
+PGF_INTERNAL_DECL
+uintptr_t pgf_unmarshall_expr(PgfUnmarshaller *u, PgfExpr e);
+
+PGF_INTERNAL_DECL
+uintptr_t pgf_unmarshall_type(PgfUnmarshaller *u, PgfType *tp);
+
 #endif /* EXPR_H_ */

src/runtime/c/pgf/namespace.h

@@ -216,10 +216,10 @@ Namespace<V> namespace_insert(Namespace<V> map, ref<V> value)
 }
 
 template <class V>
-ref<V> namespace_lookup(Namespace<V> map, const char *name)
+ref<V> namespace_lookup(Namespace<V> map, PgfText *name)
 {
     while (map != 0) {
-        int cmp = strcmp(name,map->value->name);
+        int cmp = textcmp(name,&map->value->name);
         if (cmp < 0)
             map = map->left;
         else if (cmp > 0)
@@ -227,7 +227,7 @@ ref<V> namespace_lookup(Namespace<V> map, const char *name)
         else
             return map->value;
     }
-    return NULL;
+    return 0;
 }
 
 template <class V>

src/runtime/c/pgf/pgf.cxx

@@ -11,14 +11,16 @@ pgf_exn_clear(PgfExn* err)
 }
 
 PGF_API
-PgfPGF *pgf_read_pgf(const char* fpath, PgfExn* err)
+PgfPGF *pgf_read_pgf(const char* fpath,
+                     PgfUnmarshaller *unmarshaller,
+                     PgfExn* err)
 {
     PgfPGF *pgf = NULL;
 
     pgf_exn_clear(err);
 
     try {
-        pgf = new PgfPGF(NULL, 0, 0);
+        pgf = new PgfPGF(NULL, 0, 0, unmarshaller);
 
         std::ifstream in(fpath, std::ios::binary);
         if (in.fail()) {
@@ -50,14 +52,16 @@ PgfPGF *pgf_read_pgf(const char* fpath, PgfExn* err)
 }
 
 PGF_API
-PgfPGF *pgf_boot_ngf(const char* pgf_path, const char* ngf_path, PgfExn* err)
+PgfPGF *pgf_boot_ngf(const char* pgf_path, const char* ngf_path,
+                     PgfUnmarshaller *unmarshaller,
+                     PgfExn* err)
 {
     PgfPGF *pgf = NULL;
 
     pgf_exn_clear(err);
 
     try {
-        pgf = new PgfPGF(ngf_path, O_CREAT | O_EXCL | O_RDWR, S_IRUSR | S_IWUSR);
+        pgf = new PgfPGF(ngf_path, O_CREAT | O_EXCL | O_RDWR, S_IRUSR | S_IWUSR, unmarshaller);
 
         std::ifstream in(pgf_path, std::ios::binary);
         if (in.fail()) {
@@ -93,7 +97,9 @@ PgfPGF *pgf_boot_ngf(const char* pgf_path, const char* ngf_path, PgfExn* err)
 }
 
 PGF_API
-PgfPGF *pgf_read_ngf(const char *fpath, PgfExn* err)
+PgfPGF *pgf_read_ngf(const char *fpath,
+                     PgfUnmarshaller *unmarshaller,
+                     PgfExn* err)
 {
     PgfPGF *pgf = NULL;
 
@@ -101,7 +107,7 @@ PgfPGF *pgf_read_ngf(const char *fpath, PgfExn* err)
 
     bool is_new = false;
     try {
-        pgf = new PgfPGF(fpath, O_CREAT | O_RDWR, S_IRUSR | S_IWUSR);
+        pgf = new PgfPGF(fpath, O_CREAT | O_RDWR, S_IRUSR | S_IWUSR, unmarshaller);
 
         {
             DB_scope scope(pgf, WRITER_SCOPE);
@@ -195,3 +201,16 @@ void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfText* cat, PgfItor* itor)
     helper.itor = itor;
     namespace_iter(pgf->get_root<PgfPGFRoot>()->abstract.funs, &helper);
 }
+
+PGF_API uintptr_t
+pgf_function_type(PgfPGF* pgf, PgfText *funname)
+{
+    DB_scope scope(pgf, READER_SCOPE);
+
+    ref<PgfAbsFun> absfun =
+        namespace_lookup(pgf->get_root<PgfPGFRoot>()->abstract.funs, funname);
+	if (absfun == 0)
+		return 0;
+
+	return pgf_unmarshall_type(pgf->u, absfun->type);
+}

src/runtime/c/pgf/pgf.h

@@ -37,6 +37,9 @@
 
 #endif
 
+#include<stdint.h>
+#include <sys/types.h>
+
 /* A generic structure to store text. The last field is variable length */
 typedef struct {
     size_t size;
@@ -50,6 +53,49 @@ struct PgfItor {
 	void (*fn)(PgfItor* self, PgfText* key, void *value);
 };
 
+typedef enum {
+	PGF_BIND_TYPE_EXPLICIT,
+	PGF_BIND_TYPE_IMPLICIT
+} PgfBindType;
+
+typedef int PgfMetaId;
+
+typedef struct {
+    PgfBindType bind_type;
+	PgfText *cid;
+	uintptr_t type;
+} PgfTypeHypo;
+
+/* This structure tells the runtime how to create abstract syntax
+ * expressions in the heap of the host language. For instance,
+ * when used from Haskell the runtime will create values of
+ * an algebraic data type which can be garbage collected
+ * when not needed. Similarly in Python the expressions are
+ * normal Python objects. From the point of view of the runtime,
+ * each node is a value of type uintptr_t. For Haskell that would
+ * actually be a stable pointer, while for Python that would be
+ * a PyObject pointer.
+ */
+typedef struct PgfUnmarshaller PgfUnmarshaller;
+struct PgfUnmarshaller {
+    uintptr_t (*eabs)(PgfBindType btype, PgfText *name, uintptr_t body);
+    uintptr_t (*eapp)(uintptr_t fun, uintptr_t arg);
+    uintptr_t (*elit)(uintptr_t lit);
+    uintptr_t (*emeta)(PgfMetaId meta);
+    uintptr_t (*efun)(PgfText *name);
+    uintptr_t (*evar)(int index);
+    uintptr_t (*etyped)(uintptr_t expr, uintptr_t typ);
+    uintptr_t (*eimplarg)(uintptr_t expr);
+    uintptr_t (*lint)(int v);
+    uintptr_t (*lflt)(double v);
+    uintptr_t (*lstr)(PgfText *v);
+    uintptr_t (*dtyp)(int n_hypos, PgfTypeHypo *hypos,
+                      PgfText *cat,
+                      int n_exprs, uintptr_t *exprs);
+    void (*free_ref)(uintptr_t x);
+    void (*free_me)(PgfUnmarshaller *unmarshaller);
+};
+
 typedef struct PgfPGF PgfPGF;
 
 /* All functions that may fail take a reference to a PgfExn structure.
@@ -82,21 +128,27 @@ typedef struct {
 
 /* Reads a PGF file and keeps it in memory. */
 PGF_API_DECL
-PgfPGF *pgf_read_pgf(const char* fpath, PgfExn* err);
+PgfPGF *pgf_read_pgf(const char* fpath,
+                     PgfUnmarshaller *unmarshaller,
+                     PgfExn* err);
 
 /* Reads a PGF file and stores the unpacked data in an NGF file
  * ready to be shared with other process, or used for quick startup.
  * The NGF file is platform dependent and should not be copied
  * between machines. */
 PGF_API_DECL
-PgfPGF *pgf_boot_ngf(const char* pgf_path, const char* ngf_path, PgfExn* err);
+PgfPGF *pgf_boot_ngf(const char* pgf_path, const char* ngf_path,
+                     PgfUnmarshaller *unmarshaller,
+                     PgfExn* err);
 
 /* Tries to read the grammar from an already booted NGF file.
  * If the file does not exist then a new one is created, and the
  * grammar is set to be empty. It can later be populated with
  * rules dynamically. */
 PGF_API_DECL
-PgfPGF *pgf_read_ngf(const char* fpath, PgfExn* err);
+PgfPGF *pgf_read_ngf(const char* fpath,
+                     PgfUnmarshaller *unmarshaller,
+                     PgfExn* err);
 
 /* Release the grammar when it is no longer needed. */
 PGF_API_DECL

src/runtime/haskell/PGF2.hsc

@@ -22,6 +22,7 @@ module PGF2 (-- * PGF
              Cat,categories,
              -- ** Functions
              Fun, functions, functionsByCat,
+             functionType,
              -- ** Expressions
              Expr(..), Literal(..),
              -- ** Types
@@ -52,15 +53,18 @@ readPGF fpath =
   withCString fpath $ \c_fpath ->
   allocaBytes (#size PgfExn) $ \c_exn ->
   mask_ $ do
-    c_pgf <- pgf_read_pgf c_fpath c_exn
+    u <- mkUnmarshaller
+    c_pgf <- pgf_read_pgf c_fpath u c_exn
     ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
     if ex_type == (#const PGF_EXN_NONE)
       then do fptr <- newForeignPtr pgf_free_fptr c_pgf
               return (PGF fptr Map.empty)
       else if ex_type == (#const PGF_EXN_SYSTEM_ERROR)
-             then do errno <- (#peek PgfExn, code) c_exn
+             then do freeUnmarshaller u
+                     errno <- (#peek PgfExn, code) c_exn
                      ioError (errnoToIOError "readPGF" (Errno errno) Nothing (Just fpath))
-             else do c_msg <- (#peek PgfExn, msg) c_exn
+             else do freeUnmarshaller u
+                     c_msg <- (#peek PgfExn, msg) c_exn
                      msg <- peekCString c_msg
                      free c_msg
                      throwIO (PGFError msg)
@@ -75,15 +79,18 @@ bootNGF pgf_path ngf_path =
   withCString ngf_path $ \c_ngf_path ->
   allocaBytes (#size PgfExn) $ \c_exn ->
   mask_ $ do
-    c_pgf <- pgf_boot_ngf c_pgf_path c_ngf_path c_exn
+    u <- mkUnmarshaller
+    c_pgf <- pgf_boot_ngf c_pgf_path c_ngf_path u c_exn
     ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
     if ex_type == (#const PGF_EXN_NONE)
       then do fptr <- newForeignPtr pgf_free_fptr c_pgf
               return (PGF fptr Map.empty)
       else if ex_type == (#const PGF_EXN_SYSTEM_ERROR)
-             then do errno <- (#peek PgfExn, code) c_exn
+             then do freeUnmarshaller u
+                     errno <- (#peek PgfExn, code) c_exn
                      ioError (errnoToIOError "bootNGF" (Errno errno) Nothing (Just pgf_path))
-             else do c_msg <- (#peek PgfExn, msg) c_exn
+             else do freeUnmarshaller u
+                     c_msg <- (#peek PgfExn, msg) c_exn
                      msg <- peekCString c_msg
                      free c_msg
                      throwIO (PGFError msg)
@@ -97,15 +104,18 @@ readNGF fpath =
   withCString fpath $ \c_fpath ->
   allocaBytes (#size PgfExn) $ \c_exn ->
   mask_ $ do
-    c_pgf <- pgf_read_ngf c_fpath c_exn
+    u <- mkUnmarshaller
+    c_pgf <- pgf_read_ngf c_fpath u c_exn
     ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
     if ex_type == (#const PGF_EXN_NONE)
       then do fptr <- newForeignPtr pgf_free_fptr c_pgf
               return (PGF fptr Map.empty)
       else if ex_type == (#const PGF_EXN_SYSTEM_ERROR)
-             then do errno <- (#peek PgfExn, code) c_exn
+             then do freeUnmarshaller u
+                     errno <- (#peek PgfExn, code) c_exn
                      ioError (errnoToIOError "readPGF" (Errno errno) Nothing (Just fpath))
-             else do c_msg <- (#peek PgfExn, msg) c_exn
+             else do freeUnmarshaller u
+                     c_msg <- (#peek PgfExn, msg) c_exn
                      msg <- peekCString c_msg
                      free c_msg
                      throwIO (PGFError msg)
@@ -119,6 +129,19 @@ abstractName p =
   bracket (pgf_abstract_name p_pgf) free $ \c_text ->
     peekText c_text
 
+-- | The type of a function
+functionType :: PGF -> Fun -> Maybe Type
+functionType p fn =
+  unsafePerformIO $
+  withForeignPtr (a_pgf p) $ \p_pgf ->
+  withText fn $ \c_fn -> do
+    c_typ <- pgf_function_type p_pgf c_fn
+    if c_typ == castPtrToStablePtr nullPtr
+      then return Nothing
+      else do typ <- deRefStablePtr c_typ
+              freeStablePtr c_typ
+              return (Just typ)
+
 -- | List of all functions defined in the abstract syntax
 categories :: PGF -> [Fun]
 categories p =

src/runtime/haskell/PGF2/FFI.hsc

@@ -6,9 +6,10 @@ import Data.Word
 import Foreign
 import Foreign.C
 import Foreign.Ptr
-import Foreign.ForeignPtr
 import qualified Data.Map as Map
 
+import PGF2.Expr
+
 #include <pgf/pgf.h>
 
 -- | An abstract data type representing multilingual grammar
@@ -24,6 +25,8 @@ data PgfText
 data PgfItor
 data PgfPGF
 data PgfConcr
+data PgfTypeHypo
+data PgfUnmarshaller
 
 foreign import ccall unsafe "pgf_utf8_decode"
   pgf_utf8_decode :: Ptr CString -> IO Word32
@@ -32,13 +35,13 @@ foreign import ccall unsafe "pgf_utf8_encode"
   pgf_utf8_encode :: Word32 -> Ptr CString -> IO ()
 
 foreign import ccall "pgf_read_pgf"
-  pgf_read_pgf :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
+  pgf_read_pgf :: CString -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfPGF)
 
 foreign import ccall "pgf_boot_ngf"
-  pgf_boot_ngf :: CString -> CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
+  pgf_boot_ngf :: CString -> CString -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfPGF)
 
 foreign import ccall "pgf_read_ngf"
-  pgf_read_ngf :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
+  pgf_read_ngf :: CString -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfPGF)
 
 foreign import ccall "&pgf_free"
   pgf_free_fptr :: FinalizerPtr PgfPGF
@@ -60,6 +63,10 @@ foreign import ccall "pgf_iter_functions"
 foreign import ccall "pgf_iter_functions_by_cat"
   pgf_iter_functions_by_cat :: Ptr PgfPGF -> Ptr PgfText -> Ptr PgfItor -> IO ()
 
+foreign import ccall "pgf/pgf.h pgf_function_type"
+   pgf_function_type :: Ptr PgfPGF -> Ptr PgfText -> IO (StablePtr Type)
+
+
 peekText :: Ptr PgfText -> IO String
 peekText ptr =
   alloca $ \pptr -> do
@@ -107,3 +114,171 @@ withText s fn =
           | otherwise       = count (c+6) xs
           where
             ucs = fromEnum x
+
+
+type CBindType = (#type PgfBindType)
+
+type EAbsUnmarshaller = (#type PgfBindType) -> Ptr PgfText -> StablePtr Expr -> IO (StablePtr Expr)
+
+foreign import ccall "wrapper"
+  wrapEAbsUnmarshaller :: EAbsUnmarshaller -> IO (FunPtr EAbsUnmarshaller)
+
+type EAppUnmarshaller = StablePtr Expr -> StablePtr Expr -> IO (StablePtr Expr)
+
+foreign import ccall "wrapper"
+  wrapEAppUnmarshaller :: EAppUnmarshaller -> IO (FunPtr EAppUnmarshaller)
+
+type ELitUnmarshaller = StablePtr Literal -> IO (StablePtr Expr)
+
+foreign import ccall "wrapper"
+  wrapELitUnmarshaller :: ELitUnmarshaller -> IO (FunPtr ELitUnmarshaller)
+
+type EMetaUnmarshaller = (#type PgfMetaId) -> IO (StablePtr Expr)
+
+foreign import ccall "wrapper"
+  wrapEMetaUnmarshaller :: EMetaUnmarshaller -> IO (FunPtr EMetaUnmarshaller)
+
+type EFunUnmarshaller = Ptr PgfText -> IO (StablePtr Expr)
+
+foreign import ccall "wrapper"
+  wrapEFunUnmarshaller :: EFunUnmarshaller -> IO (FunPtr EFunUnmarshaller)
+
+type EVarUnmarshaller = CInt -> IO (StablePtr Expr)
+
+foreign import ccall "wrapper"
+  wrapEVarUnmarshaller :: EVarUnmarshaller -> IO (FunPtr EVarUnmarshaller)
+
+type ETypedUnmarshaller = StablePtr Expr -> StablePtr Type -> IO (StablePtr Expr)
+
+foreign import ccall "wrapper"
+  wrapETypedUnmarshaller :: ETypedUnmarshaller -> IO (FunPtr ETypedUnmarshaller)
+
+type EImplArgUnmarshaller = StablePtr Expr -> IO (StablePtr Expr)
+
+foreign import ccall "wrapper"
+  wrapEImplArgUnmarshaller :: EImplArgUnmarshaller -> IO (FunPtr EImplArgUnmarshaller)
+
+type LIntUnmarshaller = CInt -> IO (StablePtr Literal)
+
+foreign import ccall "wrapper"
+  wrapLIntUnmarshaller :: LIntUnmarshaller -> IO (FunPtr LIntUnmarshaller)
+
+type LFltUnmarshaller = CDouble -> IO (StablePtr Literal)
+
+foreign import ccall "wrapper"
+  wrapLFltUnmarshaller :: LFltUnmarshaller -> IO (FunPtr LFltUnmarshaller)
+
+type LStrUnmarshaller = Ptr PgfText -> IO (StablePtr Literal)
+
+foreign import ccall "wrapper"
+  wrapLStrUnmarshaller :: LStrUnmarshaller -> IO (FunPtr LStrUnmarshaller)
+
+type TypeUnmarshaller = CInt -> Ptr PgfTypeHypo -> Ptr PgfText -> CInt -> Ptr (StablePtr Expr) -> IO (StablePtr Type)
+
+foreign import ccall "wrapper"
+  wrapTypeUnmarshaller :: TypeUnmarshaller -> IO (FunPtr TypeUnmarshaller)
+
+foreign import ccall "&hs_free_stable_ptr" hs_free_stable_ptr :: FunPtr (StablePtr a -> IO ())
+
+foreign import ccall "&hs_free_unmarshaller" hs_free_unmarshaller :: FunPtr (Ptr PgfUnmarshaller -> IO ())
+
+foreign import ccall "hs_free_unmarshaller" freeUnmarshaller :: Ptr PgfUnmarshaller -> IO ()
+
+mkUnmarshaller = do
+  eabs    <- wrapEAbsUnmarshaller     unmarshalEAbs
+  eapp    <- wrapEAppUnmarshaller     unmarshalEApp
+  elit    <- wrapELitUnmarshaller     unmarshalELit
+  emeta   <- wrapEMetaUnmarshaller    unmarshalEMeta
+  efun    <- wrapEFunUnmarshaller     unmarshalEFun
+  evar    <- wrapEVarUnmarshaller     unmarshalEVar
+  etyped  <- wrapETypedUnmarshaller   unmarshalETyped
+  eimplarg<- wrapEImplArgUnmarshaller unmarshalEImplArg
+  lint    <- wrapLIntUnmarshaller     unmarshalLInt
+  lflt    <- wrapLFltUnmarshaller     unmarshalLFlt
+  lstr    <- wrapLStrUnmarshaller     unmarshalLStr
+  dtyp    <- wrapTypeUnmarshaller     unmarshalType
+  ptr <- mallocBytes (#size PgfUnmarshaller)
+  (#poke PgfUnmarshaller, eabs)     ptr eabs
+  (#poke PgfUnmarshaller, eapp)     ptr eapp
+  (#poke PgfUnmarshaller, elit)     ptr elit
+  (#poke PgfUnmarshaller, emeta)    ptr emeta
+  (#poke PgfUnmarshaller, efun)     ptr efun
+  (#poke PgfUnmarshaller, evar)     ptr evar
+  (#poke PgfUnmarshaller, etyped)   ptr etyped
+  (#poke PgfUnmarshaller, eimplarg) ptr eimplarg
+  (#poke PgfUnmarshaller, lint)     ptr lint
+  (#poke PgfUnmarshaller, lflt)     ptr lflt
+  (#poke PgfUnmarshaller, lstr)     ptr lstr
+  (#poke PgfUnmarshaller, dtyp)     ptr dtyp
+  (#poke PgfUnmarshaller, free_ref) ptr hs_free_stable_ptr
+  (#poke PgfUnmarshaller, free_me)  ptr hs_free_unmarshaller
+  return ptr
+  where
+    unmarshalEAbs c_btype c_var c_body = do
+      let btype = unmarshalBindType c_btype
+      var <- peekText c_var
+      body <- deRefStablePtr c_body
+      newStablePtr (EAbs btype var body)
+
+    unmarshalEApp c_fun c_arg = do
+      fun <- deRefStablePtr c_fun
+      arg <- deRefStablePtr c_arg
+      newStablePtr (EApp fun arg)
+
+    unmarshalELit c_lit = do
+      lit <- deRefStablePtr c_lit
+      newStablePtr (ELit lit)
+
+    unmarshalEMeta c_metaid = do
+      newStablePtr (EMeta (fromIntegral c_metaid))
+
+    unmarshalEFun c_name = do
+      name <- peekText c_name
+      newStablePtr (EFun name)
+
+    unmarshalEVar c_var = do
+      newStablePtr (EVar (fromIntegral c_var))
+
+    unmarshalETyped c_expr c_typ = do
+      expr <- deRefStablePtr c_expr
+      typ  <- deRefStablePtr c_typ
+      newStablePtr (ETyped expr typ)
+
+    unmarshalEImplArg c_expr = do
+      expr <- deRefStablePtr c_expr
+      newStablePtr (EImplArg expr)
+
+    unmarshalLInt c_v = do
+      newStablePtr (LInt (fromIntegral c_v))
+
+    unmarshalLFlt c_v = do
+      newStablePtr (LFlt (realToFrac c_v))
+
+    unmarshalLStr c_v = do
+      s <- peekText c_v
+      newStablePtr (LStr s)
+
+    unmarshalType n_hypos hypos c_cat n_exprs exprs = do
+      hypos <- peekHypos n_hypos hypos
+      cat <- peekText c_cat
+      exprs <- peekExprs n_exprs exprs
+      newStablePtr (DTyp hypos cat exprs)
+      where
+        peekHypos 0       p_hypo = return []
+        peekHypos n_hypos p_hypo = do
+          bt  <- fmap unmarshalBindType ((#peek PgfTypeHypo, bind_type) p_hypo)
+          cid <- (#peek PgfTypeHypo, cid) p_hypo >>= peekText
+          ty  <- (#peek PgfTypeHypo, type) p_hypo >>= deRefStablePtr
+          hs  <- peekExprs (n_hypos-1) (p_hypo `plusPtr` (#size PgfTypeHypo))
+          return ((bt,cid,ty):hs)
+
+        peekExprs 0       p_expr = return []
+        peekExprs n_exprs p_expr = do
+          e  <- peek p_expr >>= deRefStablePtr
+          es <- peekExprs (n_exprs-1) (p_expr `plusPtr` (#size uintptr_t))
+          return (e:es)
+
+
+unmarshalBindType :: (#type PgfBindType) -> BindType
+unmarshalBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
+unmarshalBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit

src/runtime/haskell/pgf2.cabal

@@ -25,6 +25,7 @@ library
 
   extra-libraries:     pgf
   cc-options:          -std=c99
+  c-sources:           utils.c
 
 test-suite basic
   type:       exitcode-stdio-1.0

src/runtime/haskell/utils.c

@@ -1,160 +1,19 @@
 #include <HsFFI.h>
 #include <pgf/pgf.h>
-#include <gu/utf8.h>
 
-typedef struct {
-	PgfLiteralCallback callback;
-	PgfExprProb* (*match)(GuString ann, size_t* poffset,
-	                      GuPool *out_pool);
-	GuFinalizer fin;
-} HSPgfLiteralCallback;
-
-static size_t
-hspgf_offset2hs(GuString sentence, size_t offset)
+void hs_free_unmarshaller(PgfUnmarshaller *unmarshaller)
 {
-	const uint8_t *start = sentence;
-	const uint8_t *end   = sentence + offset;
-	size_t hs_offset = 0;
-	while (start < end) {
-		gu_utf8_decode(&start);
-		hs_offset++;
-	}
-	return hs_offset;
-}
-
-static size_t
-hspgf_hs2offset(GuString sentence, size_t hs_offset)
-{
-	const uint8_t *start = sentence;
-	const uint8_t *end   = start;
-	while (hs_offset > 0) {
-		gu_utf8_decode(&end);
-		hs_offset--;
-	}
-	
-	return (end - start);
-}
-
-static PgfExprProb*
-hspgf_match_callback(PgfLiteralCallback* self, PgfConcr* concr,
-	                 GuString ann,
-	                 GuString sentence, size_t* poffset,
-	                 GuPool *out_pool)
-{
-	HSPgfLiteralCallback* callback = (HSPgfLiteralCallback*) self;
-
-	size_t hs_offset =
-		hspgf_offset2hs(sentence, *poffset);
-	PgfExprProb* ep =
-		callback->match(ann, &hs_offset, out_pool);
-	*poffset = hspgf_hs2offset(sentence, hs_offset);
-
-	return ep;
-}
-
-static void
-hspgf_literal_callback_fin(GuFinalizer* self)
-{
-	HSPgfLiteralCallback* callback = gu_container(self, HSPgfLiteralCallback, fin);
-	
-	if (callback->callback.match != NULL)
-		hs_free_fun_ptr((HsFunPtr) callback->match);
-	if (callback->callback.predict != NULL)
-		hs_free_fun_ptr((HsFunPtr) callback->callback.predict);
-}
-
-void
-hspgf_callbacks_map_add_literal(PgfConcr* concr, PgfCallbacksMap* callbacks,
-                                PgfCId cat, HsFunPtr match, HsFunPtr predict,
-                                GuPool* pool)
-{
-	HSPgfLiteralCallback* callback = gu_new(HSPgfLiteralCallback, pool);
-	callback->callback.match   = hspgf_match_callback;
-	callback->callback.predict = (void*) predict;
-	callback->match  = (void*) match;
-	callback->fin.fn = hspgf_literal_callback_fin;
-	gu_pool_finally(pool, &callback->fin);
-	pgf_callbacks_map_add_literal(concr, callbacks, cat, &callback->callback);
-}
-
-typedef struct {
-	PgfOracleCallback oracle;
-	GuString sentence;
-    bool (*predict) (PgfCId cat,
-	                 GuString label,
-	                 size_t offset);
-	bool (*complete)(PgfCId cat,
-	                 GuString label,
-	                 size_t offset);
-    PgfExprProb* (*literal)(PgfCId cat,
-	                        GuString label,
-	                        size_t* poffset,
-	                        GuPool *out_pool);
-	GuFinalizer fin;
-} HSPgfOracleCallback;
-
-static bool
-hspgf_predict_callback(PgfOracleCallback* self,
-	                   PgfCId cat,
-	                   GuString label,
-	                   size_t offset)
-{
-	HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle);
-	return oracle->predict(cat,label,hspgf_offset2hs(oracle->sentence, offset));
-}
-
-static bool
-hspgf_complete_callback(PgfOracleCallback* self,
-	                   PgfCId cat,
-	                   GuString label,
-	                   size_t offset)
-{
-	HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle);
-	return oracle->complete(cat,label,hspgf_offset2hs(oracle->sentence, offset));
-}
-
-static PgfExprProb*
-hspgf_literal_callback(PgfOracleCallback* self,
-                       PgfCId cat,
-	                   GuString label,
-	                   size_t* poffset,
-	                   GuPool *out_pool)
-{
-	HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, oracle);
-	size_t hs_offset = hspgf_offset2hs(oracle->sentence, *poffset);
-	PgfExprProb* ep =
-		oracle->literal(cat,label,&hs_offset,out_pool);
-	*poffset = hspgf_hs2offset(oracle->sentence, hs_offset);
-	return ep;
-}
-
-static void
-hspgf_oracle_callback_fin(GuFinalizer* self)
-{
-	HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, fin);
-
-	if (oracle->predict  != NULL)
-		hs_free_fun_ptr((HsFunPtr) oracle->predict);
-	if (oracle->complete != NULL)
-		hs_free_fun_ptr((HsFunPtr) oracle->complete);
-	if (oracle->literal  != NULL)
-		hs_free_fun_ptr((HsFunPtr) oracle->literal);
-}
-
-PgfOracleCallback*
-hspgf_new_oracle_callback(GuString sentence,
-                          HsFunPtr predict, HsFunPtr complete, HsFunPtr literal,
-                          GuPool* pool)
-{
-	HSPgfOracleCallback* oracle = gu_new(HSPgfOracleCallback, pool);
-	oracle->oracle.predict  = predict  ? hspgf_predict_callback  : NULL;
-	oracle->oracle.complete = complete ? hspgf_complete_callback : NULL;
-	oracle->oracle.literal  = literal  ? hspgf_literal_callback  : NULL;
-	oracle->sentence = sentence;
-	oracle->predict  = (void*) predict;
-	oracle->complete = (void*) complete;
-	oracle->literal  = (void*) literal;
-	oracle->fin.fn = hspgf_oracle_callback_fin;
-	gu_pool_finally(pool, &oracle->fin);
-	return &oracle->oracle;
+    hs_free_fun_ptr(unmarshaller->eabs);
+    hs_free_fun_ptr(unmarshaller->eapp);
+    hs_free_fun_ptr(unmarshaller->elit);
+    hs_free_fun_ptr(unmarshaller->emeta);
+    hs_free_fun_ptr(unmarshaller->efun);
+    hs_free_fun_ptr(unmarshaller->evar);
+    hs_free_fun_ptr(unmarshaller->etyped);
+    hs_free_fun_ptr(unmarshaller->eimplarg);
+    hs_free_fun_ptr(unmarshaller->lint);
+    hs_free_fun_ptr(unmarshaller->lflt);
+    hs_free_fun_ptr(unmarshaller->lstr);
+    hs_free_fun_ptr(unmarshaller->dtyp);
+    free(unmarshaller);
 }

src/runtime/python/pypgf.c

@@ -3513,7 +3513,7 @@ pgf_readPGF(PyObject *self, PyObject *args)
 
 	// Read the PGF grammar.
     PgfExn err;
-	py_pgf->pgf = pgf_read_pgf(fpath, &err);
+	py_pgf->pgf = pgf_read_pgf(fpath, NULL/*TO BE FIXED*/, &err);
     if (err.type == PGF_EXN_SYSTEM_ERROR) {
         errno = err.code;
         PyErr_SetFromErrnoWithFilename(PyExc_IOError, fpath);