From 9a2d2b345d06b066089fe919655c5908bb7f493a Mon Sep 17 00:00:00 2001
From: krangelov <kr.angelov@gmail.com>
Date: Sat, 4 Sep 2021 07:10:04 +0200
Subject: [PATCH] an unsafe API for adding functions to the grammar. breaks
 referential transparency

---
 src/runtime/c/pgf/pgf.cxx        | 26 ++++++++++++++++++++++++++
 src/runtime/c/pgf/pgf.h          |  5 +++++
 src/runtime/haskell/PGF2.hsc     |  9 +++++++++
 src/runtime/haskell/PGF2/FFI.hsc |  4 ++++
 4 files changed, 44 insertions(+)

diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx
index 46afd78d5..55ee35880 100644
--- a/src/runtime/c/pgf/pgf.cxx
+++ b/src/runtime/c/pgf/pgf.cxx
@@ -362,3 +362,29 @@ PgfType pgf_read_type(PgfText *input, PgfUnmarshaller *u)
     }
     return res;
 }
+
+PGF_API
+void pgf_create_function(PgfPGF *pgf, PgfText *name,
+                         PgfType ty, prob_t prob,
+                         PgfMarshaller *m)
+{
+    DB_scope scope(pgf, WRITER_SCOPE);
+
+    PgfDBUnmarshaller u(m);
+
+    ref<PgfPGFRoot> root = pgf->get_root<PgfPGFRoot>();
+    ref<PgfAbsFun> absfun = DB::malloc<PgfAbsFun>(sizeof(PgfAbsFun)+name->size+1);
+    absfun->type  = m->match_type(&u, ty);
+    absfun->arity = 0;
+    absfun->defns = 0;
+    absfun->ep.prob = prob;
+    ref<PgfExprFun> efun =
+        ref<PgfExprFun>::from_ptr((PgfExprFun*) &absfun->name);
+    absfun->ep.expr = ref<PgfExprFun>::tagged(efun);
+    memcpy(&absfun->name, name, sizeof(PgfText)+name->size+1);
+    
+    Namespace<PgfAbsFun> nmsp =
+        namespace_insert(root->abstract.funs, absfun);
+    namespace_release(root->abstract.funs);
+    root->abstract.funs = nmsp;
+}
diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h
index 1810021e3..f930aacb0 100644
--- a/src/runtime/c/pgf/pgf.h
+++ b/src/runtime/c/pgf/pgf.h
@@ -290,4 +290,9 @@ PgfText *pgf_print_type(PgfType ty,
 PGF_API_DECL
 PgfType pgf_read_type(PgfText *input, PgfUnmarshaller *u);
 
+PGF_API_DECL
+void pgf_create_function(PgfPGF *pgf, PgfText *name,
+                         PgfType ty, prob_t prob,
+                         PgfMarshaller *m);
+
 #endif // PGF_H_
diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc
index b49520333..0e2dba1a9 100644
--- a/src/runtime/haskell/PGF2.hsc
+++ b/src/runtime/haskell/PGF2.hsc
@@ -40,6 +40,8 @@ module PGF2 (-- * PGF
              mkType, unType,
              mkHypo, mkDepHypo, mkImplHypo,
 
+             createFunction,
+
              -- * Concrete syntax
              ConcName,
 
@@ -315,3 +317,10 @@ readType str =
               freeStablePtr c_ty
               return (Just ty)
 
+createFunction :: PGF -> Fun -> Type -> Float -> IO ()
+createFunction p name ty prob =
+  withForeignPtr (a_pgf p) $ \p_pgf ->
+  withText name $ \c_name ->
+  bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
+  withForeignPtr marshaller $ \m -> do
+    pgf_create_function p_pgf c_name c_ty prob m
diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc
index f9e9a6530..9070251dc 100644
--- a/src/runtime/haskell/PGF2/FFI.hsc
+++ b/src/runtime/haskell/PGF2/FFI.hsc
@@ -101,6 +101,10 @@ foreign import ccall "pgf/expr.h pgf_function_is_constructor"
 foreign import ccall "pgf/expr.h pgf_function_is_constructor"
    pgf_function_prob :: Ptr PgfPGF -> Ptr PgfText -> IO (#type prob_t)
 
+foreign import ccall "pgf_create_function"
+   pgf_create_function :: Ptr PgfPGF -> Ptr PgfText -> StablePtr Type -> (#type prob_t) -> Ptr PgfMarshaller -> IO ()
+
+
 -----------------------------------------------------------------------
 -- Texts