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 #include -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