added exprSubstitute in the C runtime for substituting meta variables

5 files changed, 205 insertions, 23 deletions

diff --git a/src/runtime/c/pgf/expr.c b/src/runtime/c/pgf/expr.c
index d3df8442a..2a1d0de15 100644
--- a/src/runtime/c/pgf/expr.c
+++ b/src/runtime/c/pgf/expr.c
@@ -1271,6 +1271,165 @@ pgf_expr_functions(PgfExpr expr, GuPool* pool)
 	return gu_buf_data_seq(functions);
 }
 
+PGF_API PgfType*
+pgf_type_substitute(PgfType* type, GuSeq* meta_values, GuPool* pool)
+{
+	size_t n_hypos = gu_seq_length(type->hypos);
+	PgfHypos* new_hypos = gu_new_seq(PgfHypo, n_hypos, pool);
+	for (size_t i = 0; i < n_hypos; i++) {
+		PgfHypo* hypo     = gu_seq_index(type->hypos, PgfHypo, i);
+		PgfHypo* new_hypo = gu_seq_index(new_hypos, PgfHypo, i);
+
+		new_hypo->bind_type = hypo->bind_type;
+		new_hypo->cid       = gu_string_copy(hypo->cid, pool);
+		new_hypo->type      = pgf_type_substitute(hypo->type, meta_values, pool);
+	}
+
+	PgfType *new_type =
+		gu_new_flex(pool, PgfType, exprs, type->n_exprs);
+	new_type->hypos   = new_hypos;
+	new_type->cid     = gu_string_copy(type->cid, pool);
+	new_type->n_exprs = type->n_exprs;
+
+	for (size_t i = 0; i < type->n_exprs; i++) {
+		new_type->exprs[i] =
+			pgf_expr_substitute(type->exprs[i], meta_values, pool);
+	}
+	
+	return new_type;
+}
+
+PGF_API PgfExpr
+pgf_expr_substitute(PgfExpr expr, GuSeq* meta_values, GuPool* pool)
+{
+	GuVariantInfo ei = gu_variant_open(expr);
+	switch (ei.tag) {
+	case PGF_EXPR_ABS: {
+		PgfExprAbs* abs = ei.data;
+
+		PgfCId id    = gu_string_copy(abs->id, pool);
+		PgfExpr body = pgf_expr_substitute(abs->body, meta_values, pool);
+		return gu_new_variant_i(pool,
+								PGF_EXPR_ABS,
+								PgfExprAbs,
+								abs->bind_type, id, body);
+	}
+	case PGF_EXPR_APP: {
+		PgfExprApp* app = ei.data;
+		
+		PgfExpr fun = pgf_expr_substitute(app->fun, meta_values, pool);
+		PgfExpr arg = pgf_expr_substitute(app->arg, meta_values, pool);
+		return gu_new_variant_i(pool,
+								PGF_EXPR_APP,
+								PgfExprApp,
+								fun, arg);
+	}
+	case PGF_EXPR_LIT: {
+		PgfExprLit* elit = ei.data;
+
+		PgfLiteral lit;
+		GuVariantInfo i = gu_variant_open(elit->lit);
+		switch (i.tag) {
+		case PGF_LITERAL_STR: {
+			PgfLiteralStr* lstr = i.data;
+
+			PgfLiteralStr* new_lstr =
+				gu_new_flex_variant(PGF_LITERAL_STR,
+				                    PgfLiteralStr,
+				                    val, strlen(lstr->val)+1,
+				                    &lit, pool);
+			strcpy(new_lstr->val, lstr->val);
+			break;
+		}
+		case PGF_LITERAL_INT: {
+			PgfLiteralInt* lint = i.data;
+
+			PgfLiteralInt* new_lint =
+				gu_new_variant(PGF_LITERAL_INT,
+				               PgfLiteralInt,
+				               &lit, pool);
+			new_lint->val = lint->val;
+			break;
+		}
+		case PGF_LITERAL_FLT: {
+			PgfLiteralFlt* lflt = i.data;
+
+			PgfLiteralFlt* new_lflt =
+				gu_new_variant(PGF_LITERAL_FLT,
+				               PgfLiteralFlt,
+				               &lit, pool);
+			new_lflt->val = lflt->val;
+			break;
+		}
+		default:
+			gu_impossible();
+		}
+		
+		return gu_new_variant_i(pool,
+		                        PGF_EXPR_LIT,
+			                    PgfExprLit,
+			                    lit);
+	}
+	case PGF_EXPR_META: {
+		PgfExprMeta* meta = ei.data;
+		PgfExpr e = gu_null_variant;
+		if ((size_t) meta->id < gu_seq_length(meta_values)) {
+			e = gu_seq_get(meta_values, PgfExpr, meta->id);
+		}
+		if (gu_variant_is_null(e)) {
+			e = gu_new_variant_i(pool,
+		                         PGF_EXPR_META,
+			                     PgfExprMeta,
+			                     meta->id);
+		}
+		return e;
+	}
+	case PGF_EXPR_FUN: {
+		PgfExprFun* fun = ei.data;
+
+		PgfExpr e;
+		PgfExprFun* new_fun =
+				gu_new_flex_variant(PGF_EXPR_FUN,
+				                    PgfExprFun,
+				                    fun, strlen(fun->fun)+1,
+				                    &e, pool);
+		strcpy(new_fun->fun, fun->fun);
+		return e;
+	}
+	case PGF_EXPR_VAR: {
+		PgfExprVar* var = ei.data;
+		return gu_new_variant_i(pool,
+		                        PGF_EXPR_VAR,
+			                    PgfExprVar,
+			                    var->var);
+	}
+	case PGF_EXPR_TYPED: {
+		PgfExprTyped* typed = ei.data;
+		
+		PgfExpr expr  = pgf_expr_substitute(typed->expr, meta_values, pool);
+		PgfType *type = pgf_type_substitute(typed->type, meta_values, pool);
+
+		return gu_new_variant_i(pool,
+								PGF_EXPR_TYPED,
+								PgfExprTyped,
+								expr,
+								type);
+	}
+	case PGF_EXPR_IMPL_ARG: {
+		PgfExprImplArg* impl = ei.data;
+
+		PgfExpr expr = pgf_expr_substitute(impl->expr, meta_values, pool);
+		return gu_new_variant_i(pool,
+								PGF_EXPR_IMPL_ARG,
+								PgfExprImplArg,
+								expr);
+	}
+	default:
+		gu_impossible();
+		return gu_null_variant;
+	}
+}
+
 PGF_API void
 pgf_print_cid(PgfCId id,
 			  GuOut* out, GuExn* err)
diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h
index 2f1e9ebf6..0fc6774ac 100644
--- a/src/runtime/c/pgf/expr.h
+++ b/src/runtime/c/pgf/expr.h
@@ -203,6 +203,12 @@ pgf_expr_size(PgfExpr expr);
 PGF_API GuSeq*
 pgf_expr_functions(PgfExpr expr, GuPool* pool);
 
+PGF_API PgfExpr
+pgf_expr_substitute(PgfExpr expr, GuSeq* meta_values, GuPool* pool);
+
+PGF_API PgfType*
+pgf_type_substitute(PgfType* type, GuSeq* meta_values, GuPool* pool);
+
 typedef struct PgfPrintContext PgfPrintContext;
 
 struct PgfPrintContext {
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 0d1d46be6..733e29c74 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -39,7 +39,7 @@ module PGF2 (-- * PGF
              mkFloat,unFloat,
              mkMeta,unMeta,
              mkCId,
-             exprHash, exprSize, exprFunctions,
+             exprHash, exprSize, exprFunctions, exprSubstitute,
              treeProbability,
 
              -- ** Types
@@ -366,6 +366,20 @@ exprFunctions (Expr c_expr touch) =
     touch
     return funs
 
+exprSubstitute :: Expr -> [Expr] -> Expr
+exprSubstitute (Expr c_expr touch) meta_values =
+  unsafePerformIO $
+  withGuPool $ \tmpPl -> do
+    c_meta_values <- newSequence (#size PgfExpr) pokeExpr meta_values tmpPl
+    exprPl <- gu_new_pool
+    c_expr <- pgf_expr_substitute c_expr c_meta_values exprPl
+    touch
+    exprFPl <- newForeignPtr gu_pool_finalizer exprPl
+    let touch' = sequence_ (touchForeignPtr exprFPl : map touchExpr meta_values)
+    return (Expr c_expr touch')
+  where
+    pokeExpr ptr (Expr c_expr _) = poke ptr c_expr
+
 -----------------------------------------------------------------------------
 -- Graphviz
 
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc
index c095e663f..71e4b488f 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hsc
+++ b/src/runtime/haskell-bind/PGF2/FFI.hsc
@@ -7,7 +7,7 @@ module PGF2.FFI where
 #include <gu/utf8.h>
 #include <pgf/pgf.h>
 
-import Foreign ( alloca, peek, poke )
+import Foreign ( alloca, peek, poke, peekByteOff )
 import Foreign.C
 import Foreign.Ptr
 import Foreign.ForeignPtr
@@ -216,6 +216,27 @@ utf8Length s = count 0 s
       where
         ucs = fromEnum x
 
+peekSequence peekElem size ptr = do
+  c_len <- (#peek GuSeq, len) ptr
+  peekElems (c_len :: CSizeT) (ptr `plusPtr` (#offset GuSeq, data))
+  where
+     peekElems 0   ptr = return []
+     peekElems len ptr = do
+       e  <- peekElem ptr
+       es <- peekElems (len-1) (ptr `plusPtr` size)
+       return (e:es)
+
+newSequence :: CSizeT -> (Ptr a -> v -> IO ()) -> [v] -> Ptr GuPool -> IO (Ptr GuSeq)
+newSequence elem_size pokeElem values pool = do
+  c_seq <- gu_make_seq elem_size (fromIntegral (length values)) pool
+  pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) values
+  return c_seq
+  where
+    pokeElems ptr []     = return ()
+    pokeElems ptr (x:xs) = do
+      pokeElem  ptr x
+      pokeElems (ptr `plusPtr` (fromIntegral elem_size)) xs
+
 ------------------------------------------------------------------
 -- libpgf API
 
@@ -431,6 +452,9 @@ foreign import ccall "pgf/expr.h pgf_expr_size"
 foreign import ccall "pgf/expr.h pgf_expr_functions"
   pgf_expr_functions :: PgfExpr -> Ptr GuPool -> IO (Ptr GuSeq)
 
+foreign import ccall "pgf/expr.h pgf_expr_substitute"
+  pgf_expr_substitute :: PgfExpr -> Ptr GuSeq -> Ptr GuPool -> IO PgfExpr
+
 foreign import ccall "pgf/expr.h pgf_compute_tree_probability"
   pgf_compute_tree_probability :: Ptr PgfPGF -> PgfExpr -> IO CFloat
 
diff --git a/src/runtime/haskell-bind/PGF2/Internal.hsc b/src/runtime/haskell-bind/PGF2/Internal.hsc
index 259ea670d..c4aef323a 100644
--- a/src/runtime/haskell-bind/PGF2/Internal.hsc
+++ b/src/runtime/haskell-bind/PGF2/Internal.hsc
@@ -268,16 +268,6 @@ concrSequence c seqid = unsafePerformIO $ do
       forms <- peekForms (len-1) (ptr `plusPtr` (#size PgfAlternative))
       return ((form,prefixes):forms)
 
-peekSequence peekElem size ptr = do
-  c_len <- (#peek GuSeq, len) ptr
-  peekElems (c_len :: CSizeT) (ptr `plusPtr` (#offset GuSeq, data))
-  where
-     peekElems 0   ptr = return []
-     peekElems len ptr = do
-       e  <- peekElem ptr
-       es <- peekElems (len-1) (ptr `plusPtr` size)
-       return (e:es)
-
 deRef peekValue ptr = peek ptr >>= peekValue
 
 fidString, fidInt, fidFloat, fidVar, fidStart :: FId
@@ -901,17 +891,6 @@ pokeString pool c_elem str = do
   c_str <- newUtf8CString str pool
   poke c_elem c_str
 
-newSequence :: CSizeT -> (Ptr a -> v -> IO ()) -> [v] -> Ptr GuPool -> IO (Ptr GuSeq)
-newSequence elem_size pokeElem values pool = do
-  c_seq <- gu_make_seq elem_size (fromIntegral (length values)) pool
-  pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) values
-  return c_seq
-  where
-    pokeElems ptr []     = return ()
-    pokeElems ptr (x:xs) = do
-      pokeElem  ptr x
-      pokeElems (ptr `plusPtr` (fromIntegral elem_size)) xs
-
 newMap key_size hasher newKey elem_size pokeElem values pool = do
   map <- gu_make_map key_size hasher
                      elem_size gu_null_struct