started piping PMCFG rules to the runtime

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -18,7 +18,7 @@ import GF.Infra.Option
 import GF.Infra.UseIO (IOE)
 import GF.Data.Operations
 
-import Control.Monad(forM)
+import Control.Monad(forM_)
 import Data.List
 import Data.Char
 import qualified Data.Set as Set
@@ -49,10 +49,12 @@ grammar2PGF opts gr am probs = do
     sequence_ [setAbstractFlag name value | (name,value) <- optionsPGF aflags]
     sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats]
     sequence_ [createFunction f ty arity p | (f,ty,arity,_,p) <- funs]
-    forM (allConcretes gr am) $ \cm ->
+    forM_ (allConcretes gr am) $ \cm ->
       createConcrete (mi2i cm) $ do
         let cflags = err (const noOptions) mflags (lookupModule gr cm)
         sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags]
+        forM_ (Look.allOrigInfos gr cm) createCncCats
+        forM_ (Look.allOrigInfos gr cm) createCncFuns
   return pgf
   where
     aflags = err (const noOptions) mflags (lookupModule gr am)
@@ -84,6 +86,14 @@ grammar2PGF opts gr am probs = do
                       0 -> 0
                       n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
 
+    createCncCats ((m,c),CncCat _ _ _ _ _) = do
+      createLincat (i2i c) []
+    createCncCats _ = return ()
+
+    createCncFuns ((m,f),CncFun _ _ _ (Just prods)) = do
+      createLin (i2i f) prods
+    createCncFuns _ = return ()
+
 i2i :: Ident -> String
 i2i = showIdent
 

src/runtime/c/pgf/pgf.cxx

@@ -970,6 +970,182 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
     } PGF_API_END
 }
 
+class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface
+{
+    ref<PgfConcrLin> lin;
+    size_t arg_index;
+    size_t res_index;
+    size_t seq_index;
+    size_t sym_index;
+
+public:
+    PgfLinBuilder(ref<PgfConcrLin> lin) {
+        this->lin       = lin;
+        this->arg_index = 0;
+        this->res_index = 0;
+        this->seq_index = 0;
+        this->sym_index = 0;
+    }
+
+    void start_production(PgfExn *err)
+    {
+    }
+
+    void add_argument(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)
+    {
+        ref<PgfLParam> param = PgfDB::malloc<PgfLParam>(n_terms*2*sizeof(size_t));
+        param->i0 = i0;
+        param->n_terms = n_terms;
+
+        for (size_t i = 0; i < n_terms; i++) {
+            param->terms[i].factor = terms[2*i];
+            param->terms[i].var    = terms[2*i+1];
+        }
+
+        ref<PgfPArg> parg = vector_elem(lin->args, arg_index);
+        parg->param = param;
+
+        arg_index++;
+    }
+
+    void set_result(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)
+    {
+        ref<PgfLParam> param = PgfDB::malloc<PgfLParam>(n_terms*2*sizeof(size_t));
+        param->i0 = i0;
+        param->n_terms = n_terms;
+
+        for (size_t i = 0; i < n_terms; i++) {
+            param->terms[i].factor = terms[2*i];
+            param->terms[i].var    = terms[2*i+1];
+        }
+
+        *vector_elem(lin->res, res_index) = param;
+    }
+
+    void start_sequence(size_t n_syms, PgfExn *err)
+    {
+        *vector_elem(lin->seqs, seq_index) = vector_new<PgfSymbol>(n_syms);
+        sym_index = 0;
+    }
+
+    void add_symcat(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)
+    {
+        ref<PgfSymbolCat> symcat = PgfDB::malloc<PgfSymbolCat>(n_terms*2*sizeof(size_t));
+        symcat->d  = d;
+        symcat->r.i0 = i0;
+        symcat->r.n_terms = n_terms;
+
+        for (size_t i = 0; i < n_terms; i++) {
+            symcat->r.terms[i].factor = terms[2*i];
+            symcat->r.terms[i].var    = terms[2*i+1];
+        }
+
+        ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, seq_index);
+        *vector_elem(syms, sym_index) = ref<PgfSymbolCat>::tagged(symcat);
+
+        sym_index++;
+    }
+
+    void add_symlit(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)
+    {
+        ref<PgfSymbolLit> symlit = PgfDB::malloc<PgfSymbolLit>(n_terms*2*sizeof(size_t));
+        symlit->d  = d;
+        symlit->r.i0 = i0;
+        symlit->r.n_terms = n_terms;
+
+        for (size_t i = 0; i < n_terms; i++) {
+            symlit->r.terms[i].factor = terms[2*i];
+            symlit->r.terms[i].var    = terms[2*i+1];
+        }
+
+        ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, seq_index);
+        *vector_elem(syms, sym_index) = ref<PgfSymbolLit>::tagged(symlit);
+
+        sym_index++;
+    }
+
+    void add_symvar(size_t d, size_t r, PgfExn *err)
+    {
+        ref<PgfSymbolVar> symvar = PgfDB::malloc<PgfSymbolVar>();
+        symvar->d = d;
+        symvar->r = r;
+
+        ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, seq_index);
+        *vector_elem(syms, sym_index) = ref<PgfSymbolVar>::tagged(symvar);
+
+        sym_index++;
+    }
+
+    void add_symks(PgfText *token, PgfExn *err)
+    {
+        ref<PgfSymbolKS> symtok = PgfDB::malloc<PgfSymbolKS>(token->size+1);
+        memcpy(&symtok->token, token, sizeof(PgfText)+token->size+1);
+
+        ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, seq_index);
+        *vector_elem(syms, sym_index) = ref<PgfSymbolKS>::tagged(symtok);
+
+        sym_index++;
+    }
+
+    void add_symbind(PgfExn *err)
+    {
+        ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, seq_index);
+        *vector_elem(syms, sym_index) = ref<PgfSymbolBIND>::tagged(0);
+
+        sym_index++;
+    }
+
+    void add_symsoftbind(PgfExn *err)
+    {
+        ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, seq_index);
+        *vector_elem(syms, sym_index) = ref<PgfSymbolSOFTBIND>::tagged(0);
+
+        sym_index++;
+    }
+
+    void add_symne(PgfExn *err)
+    {
+        ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, seq_index);
+        *vector_elem(syms, sym_index) = ref<PgfSymbolNE>::tagged(0);
+
+        sym_index++;
+    }
+
+    void add_symsoftspace(PgfExn *err)
+    {
+        ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, seq_index);
+        *vector_elem(syms, sym_index) = ref<PgfSymbolSOFTSPACE>::tagged(0);
+
+        sym_index++;
+    }
+
+    void add_symcapit(PgfExn *err)
+    {
+        ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, seq_index);
+        *vector_elem(syms, sym_index) = ref<PgfSymbolCAPIT>::tagged(0);
+
+        sym_index++;
+    }
+
+    void add_symallcapit(PgfExn *err)
+    {
+        ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, seq_index);
+        *vector_elem(syms, sym_index) = ref<PgfSymbolALLCAPIT>::tagged(0);
+
+        sym_index++;
+    }
+
+    void end_sequence(PgfExn *err) {
+        seq_index++;
+    }
+
+    void end_production(PgfExn *err)
+    {
+        this->res_index++;
+    }
+};
+
+
 PGF_API
 void pgf_create_lincat(PgfDB *db,
                        PgfRevision revision, PgfConcrRevision cnc_revision,
@@ -1023,7 +1199,9 @@ void pgf_drop_lincat(PgfDB *db,
 PGF_API
 void pgf_create_lin(PgfDB *db,
                     PgfRevision revision, PgfConcrRevision cnc_revision,
-                    PgfText *name, size_t n_prods, PgfExn *err)
+                    PgfText *name, size_t n_prods,
+                    PgfBuildLinIface *build,
+                    PgfExn *err)
 {
     PGF_API_BEGIN {
         DB_scope scope(db, WRITER_SCOPE);
@@ -1051,8 +1229,8 @@ void pgf_create_lin(PgfDB *db,
         lin->res  = vector_new<ref<PgfLParam>>(n_prods);
         lin->seqs = vector_new<ref<Vector<PgfSymbol>>>(n_prods*lincat->fields->len);
 
-        for (size_t i = 0; i < n_prods; i++) {
-        }
+        PgfLinBuilder builder(lin);
+        build->build(&builder, err);
 
         Namespace<PgfConcrLin> lins =
             namespace_insert(concr->lins, lin);

src/runtime/c/pgf/pgf.h

@@ -429,10 +429,72 @@ PGF_API_DECL
 void pgf_drop_lincat(PgfDB *db, PgfConcrRevision revision,
                      PgfText *name, PgfExn *err);
 
+#ifdef __cplusplus
+struct PgfLinBuilderIface {
+    virtual void start_production(PgfExn *err)=0;
+    virtual void add_argument(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
+    virtual void set_result(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
+    virtual void start_sequence(size_t n_syms, PgfExn *err)=0;
+    virtual void add_symcat(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
+    virtual void add_symlit(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
+    virtual void add_symvar(size_t d, size_t r, PgfExn *err)=0;
+    virtual void add_symks(PgfText *token, PgfExn *err)=0;
+    virtual void add_symbind(PgfExn *err)=0;
+    virtual void add_symsoftbind(PgfExn *err)=0;
+    virtual void add_symne(PgfExn *err)=0;
+    virtual void add_symsoftspace(PgfExn *err)=0;
+    virtual void add_symcapit(PgfExn *err)=0;
+    virtual void add_symallcapit(PgfExn *err)=0;
+    virtual void end_sequence(PgfExn *err)=0;
+    virtual void end_production(PgfExn *err)=0;
+};
+
+struct PgfBuildLinIface {
+    virtual void build(PgfLinBuilderIface *builder, PgfExn *err)=0;
+};
+#else
+typedef struct PgfLinBuilderIface PgfLinBuilderIface;
+
+typedef struct {
+    void (*start_production)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*add_argument)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
+    void (*set_result)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
+    void (*start_sequence)(PgfLinBuilderIface *this, size_t n_syms, PgfExn *err);
+    void (*add_symcat)(PgfLinBuilderIface *this, size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
+    void (*add_symlit)(PgfLinBuilderIface *this, size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
+    void (*add_symvar)(PgfLinBuilderIface *this, size_t d, size_t r, PgfExn *err);
+    void (*add_symks)(PgfLinBuilderIface *this, PgfText *token, PgfExn *err);
+    void (*add_symbind)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*add_symsoftbind)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*add_symne)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*add_symsoftspace)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*add_symcapit)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*add_symallcapit)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*end_sequence)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*end_production)(PgfLinBuilderIface *this, PgfExn *err);
+} PgfLinBuilderIfaceVtbl;
+
+struct PgfLinBuilderIface {
+    PgfLinBuilderIfaceVtbl *vtbl;
+};
+
+typedef struct PgfBuildLinIface PgfBuildLinIface;
+
+typedef struct {
+    void (*build)(PgfBuildLinIface *this, PgfLinBuilderIface *builder, PgfExn *err);
+} PgfBuildLinIfaceVtbl;
+
+struct PgfBuildLinIface {
+    PgfBuildLinIfaceVtbl *vtbl;
+};
+#endif
+
 PGF_API_DECL
 void pgf_create_lin(PgfDB *db,
                     PgfRevision revision, PgfConcrRevision cnc_revision,
-                    PgfText *name, size_t n_prods, PgfExn *err);
+                    PgfText *name, size_t n_prods,
+                    PgfBuildLinIface *build,
+                    PgfExn *err);
 
 PGF_API_DECL
 void pgf_drop_lin(PgfDB *db, PgfConcrRevision revision,

src/runtime/haskell/PGF2/FFI.hsc

@@ -41,6 +41,11 @@ data PgfPrintContext
 data PgfTypeHypo
 data PgfMarshaller
 data PgfUnmarshaller
+data PgfBuildLinIface
+data PgfLinBuilderIface
+
+type Wrapper a = a -> IO (FunPtr a)
+type Dynamic a = FunPtr a -> a
 
 foreign import ccall unsafe "pgf_utf8_decode"
   pgf_utf8_decode :: Ptr CString -> IO Word32
@@ -90,8 +95,7 @@ foreign import ccall "pgf_read_type"
 
 type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO ()
 
-foreign import ccall "wrapper"
-  wrapItorCallback :: ItorCallback -> IO (FunPtr ItorCallback)
+foreign import ccall "wrapper" wrapItorCallback :: Wrapper ItorCallback
 
 foreign import ccall pgf_iter_categories :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO ()
 
@@ -139,11 +143,25 @@ foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -
 
 foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
+foreign import ccall "wrapper" wrapLinBuild :: Wrapper (Ptr PgfBuildLinIface -> Ptr PgfLinBuilderIface -> Ptr PgfExn -> IO ())
+
+foreign import ccall "dynamic" callLinBuilder0 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfExn -> IO ())
+
+foreign import ccall "dynamic" callLinBuilder1 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> Ptr PgfExn -> IO ())
+
+foreign import ccall "dynamic" callLinBuilder2 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr PgfExn -> IO ())
+
+foreign import ccall "dynamic" callLinBuilder3 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
+
+foreign import ccall "dynamic" callLinBuilder4 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
+
+foreign import ccall "dynamic" callLinBuilder5 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfText -> Ptr PgfExn -> IO ())
+
 foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
@@ -272,99 +290,75 @@ 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 "dynamic" callEAbsFun :: Dynamic EAbsFun
 
-foreign import ccall "wrapper"
-  wrapEAbsFun :: EAbsFun -> IO (FunPtr EAbsFun)
+foreign import ccall "wrapper" wrapEAbsFun :: Wrapper EAbsFun
 
 type EAppFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Expr -> IO (StablePtr Expr)
 
-foreign import ccall "dynamic"
-  callEAppFun :: FunPtr EAppFun -> EAppFun
+foreign import ccall "dynamic" callEAppFun :: Dynamic EAppFun
 
-foreign import ccall "wrapper"
-  wrapEAppFun :: EAppFun -> IO (FunPtr EAppFun)
+foreign import ccall "wrapper" wrapEAppFun :: Wrapper EAppFun
 
 type ELitFun = Ptr PgfUnmarshaller -> StablePtr Literal -> IO (StablePtr Expr)
 
-foreign import ccall "dynamic"
-  callELitFun :: FunPtr ELitFun -> ELitFun
+foreign import ccall "dynamic" callELitFun :: Dynamic ELitFun
 
-foreign import ccall "wrapper"
-  wrapELitFun :: ELitFun -> IO (FunPtr ELitFun)
+foreign import ccall "wrapper" wrapELitFun :: Wrapper ELitFun
 
 type EMetaFun = Ptr PgfUnmarshaller -> (#type PgfMetaId) -> IO (StablePtr Expr)
 
-foreign import ccall "dynamic"
-  callEMetaFun :: FunPtr EMetaFun -> EMetaFun
+foreign import ccall "dynamic" callEMetaFun :: Dynamic EMetaFun
 
-foreign import ccall "wrapper"
-  wrapEMetaFun :: EMetaFun -> IO (FunPtr EMetaFun)
+foreign import ccall "wrapper" wrapEMetaFun :: Wrapper EMetaFun
 
 type EFunFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Expr)
 
-foreign import ccall "dynamic"
-  callEFunFun :: FunPtr EFunFun -> EFunFun
+foreign import ccall "dynamic" callEFunFun :: Dynamic EFunFun
 
-foreign import ccall "wrapper"
-  wrapEFunFun :: EFunFun -> IO (FunPtr EFunFun)
+foreign import ccall "wrapper" wrapEFunFun :: Wrapper EFunFun
 
 type EVarFun = Ptr PgfUnmarshaller -> CInt -> IO (StablePtr Expr)
 
-foreign import ccall "dynamic"
-  callEVarFun :: FunPtr EVarFun -> EVarFun
+foreign import ccall "dynamic" callEVarFun :: Dynamic EVarFun
 
-foreign import ccall "wrapper"
-  wrapEVarFun :: EVarFun -> IO (FunPtr EVarFun)
+foreign import ccall "wrapper" wrapEVarFun :: Wrapper EVarFun
 
 type ETypedFun = Ptr PgfUnmarshaller -> StablePtr Expr -> StablePtr Type -> IO (StablePtr Expr)
 
-foreign import ccall "dynamic"
-  callETypedFun :: FunPtr ETypedFun -> ETypedFun
+foreign import ccall "dynamic" callETypedFun :: Dynamic ETypedFun
 
-foreign import ccall "wrapper"
-  wrapETypedFun :: ETypedFun -> IO (FunPtr ETypedFun)
+foreign import ccall "wrapper" wrapETypedFun :: Wrapper ETypedFun
 
 type EImplArgFun = Ptr PgfUnmarshaller -> StablePtr Expr -> IO (StablePtr Expr)
 
-foreign import ccall "dynamic"
-  callEImplArgFun :: FunPtr EImplArgFun -> EImplArgFun
+foreign import ccall "dynamic" callEImplArgFun :: Dynamic EImplArgFun
 
-foreign import ccall "wrapper"
-  wrapEImplArgFun :: EImplArgFun -> IO (FunPtr EImplArgFun)
+foreign import ccall "wrapper" wrapEImplArgFun :: Wrapper EImplArgFun
 
 type LIntFun = Ptr PgfUnmarshaller -> (#type size_t) -> Ptr (#type uintmax_t) -> IO (StablePtr Literal)
 
-foreign import ccall "dynamic"
-  callLIntFun :: FunPtr LIntFun -> LIntFun
+foreign import ccall "dynamic" callLIntFun :: Dynamic LIntFun
 
-foreign import ccall "wrapper"
-  wrapLIntFun :: LIntFun -> IO (FunPtr LIntFun)
+foreign import ccall "wrapper" wrapLIntFun :: Wrapper LIntFun
 
 type LFltFun = Ptr PgfUnmarshaller -> CDouble -> IO (StablePtr Literal)
 
-foreign import ccall "dynamic"
-  callLFltFun :: FunPtr LFltFun -> LFltFun
+foreign import ccall "dynamic" callLFltFun :: Dynamic LFltFun
 
-foreign import ccall "wrapper"
-  wrapLFltFun :: LFltFun -> IO (FunPtr LFltFun)
+foreign import ccall "wrapper" wrapLFltFun :: Wrapper LFltFun
 
 type LStrFun = Ptr PgfUnmarshaller -> Ptr PgfText -> IO (StablePtr Literal)
 
-foreign import ccall "dynamic"
-  callLStrFun :: FunPtr LStrFun -> LStrFun
+foreign import ccall "dynamic" callLStrFun :: Dynamic LStrFun
 
-foreign import ccall "wrapper"
-  wrapLStrFun :: LStrFun -> IO (FunPtr LStrFun)
+foreign import ccall "wrapper" wrapLStrFun :: Wrapper LStrFun
 
 type DTypFun = Ptr PgfUnmarshaller -> CSize -> Ptr PgfTypeHypo -> Ptr PgfText -> CSize -> Ptr (StablePtr Expr) -> IO (StablePtr Type)
 
-foreign import ccall "dynamic"
-  callDTypFun :: FunPtr DTypFun -> DTypFun
+foreign import ccall "dynamic" callDTypFun :: Dynamic DTypFun
 
-foreign import ccall "wrapper"
-  wrapDTypFun :: DTypFun -> IO (FunPtr DTypFun)
+foreign import ccall "wrapper" wrapDTypFun :: Wrapper DTypFun
 
 foreign import ccall "&hs_free_reference" hs_free_reference :: FunPtr (Ptr a -> StablePtr a -> IO ())
 
@@ -372,10 +366,7 @@ foreign import ccall "&hs_free_marshaller" hs_free_marshaller :: FinalizerPtr Pg
 
 foreign import ccall "&hs_free_unmarshaller" hs_free_unmarshaller :: FinalizerPtr PgfUnmarshaller
 
-type MatchFun a = Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr a -> IO (StablePtr a)
-
-foreign import ccall "wrapper"
-  wrapMatchFun :: MatchFun a -> IO (FunPtr (MatchFun a))
+foreign import ccall "wrapper" wrapMatchFun :: Wrapper (Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> StablePtr a -> IO (StablePtr a))
 
 {-# NOINLINE marshaller #-}
 marshaller = unsafePerformIO $ do

src/runtime/haskell/PGF2/Transactions.hsc

@@ -31,6 +31,7 @@ import PGF2.Expr
 
 import Foreign
 import Foreign.C
+import Control.Monad
 import Control.Exception
 
 #include <pgf/pgf.h>
@@ -224,9 +225,79 @@ dropLincat name = Transaction $ \c_db _ c_revision c_exn ->
     pgf_drop_lincat c_db c_revision c_name c_exn
 
 createLin :: Fun -> [Production] -> Transaction Concr ()
-createLin name rules = Transaction $ \c_db c_abstr c_revision c_exn ->
+createLin name prods = Transaction $ \c_db c_abstr c_revision c_exn ->
   withText name $ \c_name ->
-    pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length rules)) c_exn
+  allocaBytes (#size PgfBuildLinIface) $ \c_build ->
+  allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl ->
+  bracket (wrapLinBuild build) freeHaskellFunPtr $ \c_callback -> do
+    (#poke PgfBuildLinIface, vtbl) c_build vtbl
+    (#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback
+    pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
+  where
+    build _ c_builder c_exn = do
+      vtbl <- (#peek PgfLinBuilderIface, vtbl) c_builder
+      forM_ prods $ \(Production args res seqs) -> do
+        fun <- (#peek PgfLinBuilderIfaceVtbl, start_production) vtbl
+        callLinBuilder0 fun c_builder c_exn
+        fun <- (#peek PgfLinBuilderIfaceVtbl, add_argument) vtbl
+        forM_ args $ \(PArg _ param) ->
+          callLParam (callLinBuilder3 fun c_builder) param c_exn
+        fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl  
+        callLParam (callLinBuilder3 fun c_builder) res c_exn
+        forM_ seqs $ \syms -> do
+          fun <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl
+          callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn
+          mapM_ (addSymbol c_builder vtbl c_exn) syms
+          fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl
+          callLinBuilder0 fun c_builder c_exn
+        fun <- (#peek PgfLinBuilderIfaceVtbl, end_production) vtbl
+        callLinBuilder0 fun c_builder c_exn
+        return ()
+
+    addSymbol c_builder vtbl c_exn (SymCat d r) = do
+      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symcat) vtbl
+      callLParam (callLinBuilder4 fun c_builder (fromIntegral d)) r c_exn
+    addSymbol c_builder vtbl c_exn (SymLit d r) = do
+      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symlit) vtbl
+      callLParam (callLinBuilder4 fun c_builder (fromIntegral d)) r c_exn
+    addSymbol c_builder vtbl c_exn (SymVar d r) = do
+      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symvar) vtbl
+      callLinBuilder2 fun c_builder (fromIntegral d) (fromIntegral r) c_exn
+    addSymbol c_builder vtbl c_exn (SymKS tok) = do
+      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symvar) vtbl
+      withText tok $ \c_tok ->
+        callLinBuilder5 fun c_builder c_tok c_exn
+    addSymbol c_builder vtbl c_exn SymBIND = do
+      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symbind) vtbl
+      callLinBuilder0 fun c_builder c_exn
+    addSymbol c_builder vtbl c_exn SymSOFT_BIND = do
+      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symsoftbind) vtbl
+      callLinBuilder0 fun c_builder c_exn
+    addSymbol c_builder vtbl c_exn SymNE = do
+      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symne) vtbl
+      callLinBuilder0 fun c_builder c_exn
+    addSymbol c_builder vtbl c_exn SymSOFT_SPACE = do
+      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symsoftspace) vtbl
+      callLinBuilder0 fun c_builder c_exn
+    addSymbol c_builder vtbl c_exn SymCAPIT = do
+      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symcapit) vtbl
+      callLinBuilder0 fun c_builder c_exn
+    addSymbol c_builder vtbl c_exn SymALL_CAPIT = do
+      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symallcapit) vtbl
+      callLinBuilder0 fun c_builder c_exn
+
+    callLParam f (LParam i0 terms) c_exn =
+      allocaBytes ((#size size_t)*2*n_terms) $ \c_terms -> do
+        pokeTerms c_terms terms
+        f (fromIntegral i0) (fromIntegral n_terms) c_terms c_exn
+      where
+        n_terms = length terms
+
+        pokeTerms c_terms []                  = return ()
+        pokeTerms c_terms ((index,var):terms) = do
+          pokeElemOff c_terms 0 (fromIntegral index)
+          pokeElemOff c_terms 1 (fromIntegral var)
+          pokeTerms (c_terms `plusPtr` ((#size size_t) * 2)) terms
 
 dropLin :: Fun -> Transaction Concr ()
 dropLin name = Transaction $ \c_db _ c_revision c_exn ->