diff --git a/src/runtime/c/pgf/expr.cxx b/src/runtime/c/pgf/expr.cxx index 8ae2dcbba..ccea7924f 100644 --- a/src/runtime/c/pgf/expr.cxx +++ b/src/runtime/c/pgf/expr.cxx @@ -222,6 +222,79 @@ void PgfDBUnmarshaller::free_ref(object x) PgfDB::free(ref::untagged(x)); } +PgfLiteral PgfInternalMarshaller::match_lit(PgfUnmarshaller *u, PgfLiteral l) +{ + switch (ref::get_tag(l)) { + case PgfLiteralInt::tag: { + auto lint = ref::untagged(l); + return u->lint(lint->size, lint->val); + } + case PgfLiteralFlt::tag: { + return u->lflt(ref::untagged(l)->val); + } + case PgfLiteralStr::tag: { + return u->lstr(&ref::untagged(l)->val); + } + default: + throw pgf_error("Unknown literal tag"); + } +} + +PgfExpr PgfInternalMarshaller::match_expr(PgfUnmarshaller *u, PgfExpr e) +{ + switch (ref::get_tag(e)) { + case PgfExprAbs::tag: { + auto eabs = ref::untagged(e); + return u->eabs(eabs->bind_type,&eabs->name,eabs->body); + } + case PgfExprApp::tag: { + auto eapp = ref::untagged(e); + return u->eapp(eapp->fun,eapp->arg); + } + case PgfExprLit::tag: { + auto elit = ref::untagged(e); + return u->elit(elit->lit); + } + case PgfExprMeta::tag: { + return u->emeta(ref::untagged(e)->id); + } + case PgfExprFun::tag: { + return u->efun(&ref::untagged(e)->name); + } + case PgfExprVar::tag: { + return u->evar(ref::untagged(e)->var); + } + case PgfExprTyped::tag: { + auto etyped = ref::untagged(e); + return u->etyped(etyped->expr,etyped->type.as_object()); + } + case PgfExprImplArg::tag: { + auto eimpl = ref::untagged(e); + return u->eimplarg(eimpl->expr); + } + default: + throw pgf_error("Unknown expression tag"); + } +} + +PGF_INTERNAL +PgfType PgfInternalMarshaller::match_type(PgfUnmarshaller *u, PgfType ty) +{ + ref tp = ty; + + PgfTypeHypo *hypos = (PgfTypeHypo *) + alloca(tp->hypos->len * sizeof(PgfTypeHypo)); + for (size_t i = 0; i < tp->hypos->len; i++) { + hypos[i].bind_type = tp->hypos->data[i].bind_type; + hypos[i].cid = &(*tp->hypos->data[i].cid); + hypos[i].type = tp->hypos->data[i].type.as_object(); + } + + return u->dtyp(tp->hypos->len, hypos, + &tp->name, + tp->exprs->len, tp->exprs->data); +} + PgfExprParser::PgfExprParser(PgfText *input, PgfUnmarshaller *unmarshaller) { inp = input; diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h index 7524ef39e..a728c3e2a 100644 --- a/src/runtime/c/pgf/expr.h +++ b/src/runtime/c/pgf/expr.h @@ -168,6 +168,12 @@ struct PGF_INTERNAL_DECL PgfDBUnmarshaller : public PgfUnmarshaller { virtual void free_ref(object x); }; +struct PGF_INTERNAL_DECL PgfInternalMarshaller : public PgfMarshaller { + virtual object match_lit(PgfUnmarshaller *u, PgfLiteral l); + virtual object match_expr(PgfUnmarshaller *u, PgfExpr e); + virtual object match_type(PgfUnmarshaller *u, PgfType ty); +}; + typedef struct PgfBind { PgfBindType bind_type; struct PgfBind *next; diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 94292877e..0a725dc32 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -692,6 +692,49 @@ PgfType pgf_read_type(PgfText *input, PgfUnmarshaller *u) return res; } +PGF_API +PgfText *pgf_print_category_internal(object o) +{ + ref abscat = o; + + PgfInternalMarshaller m; + PgfPrinter printer(NULL,0,&m); + + printer.puts("cat "); + printer.efun(&abscat->name); + + for (size_t i = 0; i < abscat->context->len; i++) { + printer.puts(" "); + + PgfTypeHypo hypo; + hypo.bind_type = abscat->context->data[i].bind_type; + hypo.cid = abscat->context->data[i].cid; + hypo.type = abscat->context->data[i].type.as_object(); + printer.hypo(&hypo,4); + } + + printer.nprintf(32, " ; -- %g", abscat->prob); + + return printer.get_text(); +} + +PGF_API +PgfText *pgf_print_function_internal(object o) +{ + ref absfun = o; + + PgfInternalMarshaller m; + PgfPrinter printer(NULL,0,&m); + + printer.puts("fun "); + printer.efun(&absfun->name); + printer.puts(" : "); + m.match_type(&printer, absfun->type.as_object()); + printer.nprintf(32, " ; -- %g", absfun->ep.prob); + + return printer.get_text(); +} + PGF_API PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision, PgfText *name, diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 4b868bae6..865bd0cd0 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -371,6 +371,12 @@ PgfText *pgf_print_context(size_t n_hypos, PgfTypeHypo *hypos, PGF_API_DECL PgfType pgf_read_type(PgfText *input, PgfUnmarshaller *u); +PGF_API_DECL +PgfText *pgf_print_category_internal(object o); + +PGF_API_DECL +PgfText *pgf_print_function_internal(object o); + PGF_API_DECL PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision, PgfText *name, diff --git a/src/runtime/c/pgf/printer.h b/src/runtime/c/pgf/printer.h index a640eb9d9..b476c5026 100644 --- a/src/runtime/c/pgf/printer.h +++ b/src/runtime/c/pgf/printer.h @@ -46,8 +46,6 @@ public: // it will be allocated automatically. void nprintf(size_t buf_size, const char *format, ...) __attribute__ ((format (printf, 3, 4))); - void print_name(PgfText *name); - PgfText *get_text(); void hypo(PgfTypeHypo *hypo, int prio); diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index e44a1d23c..d08852cc2 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -170,8 +170,10 @@ writePGF fpath p = showPGF :: PGF -> String showPGF p = render (text "abstract" <+> ppAbstractName p <+> char '{' $$ - nest 4 (ppAbsCats p) $$ - char '}') + nest 2 (ppAbsCats p $$ + ppAbsFuns p) $$ + char '}' $$ + Map.foldrWithKey (\name concr doc -> ppConcr name concr $$ doc) empty (languages p)) where ppAbstractName p = unsafePerformIO $ @@ -180,7 +182,39 @@ showPGF p = bracket (pgf_print_ident c_text) free $ \c_text -> fmap text (peekText c_text) - ppAbsCats p = empty + ppAbsCats p = unsafePerformIO $ do + ref <- newIORef empty + (allocaBytes (#size PgfItor) $ \itor -> + bracket (wrapItorCallback (getCategories ref)) freeHaskellFunPtr $ \fptr -> + withForeignPtr (a_revision p) $ \c_revision -> do + (#poke PgfItor, fn) itor fptr + withPgfExn "categories" (pgf_iter_categories (a_db p) c_revision itor)) + readIORef ref + where + getCategories :: IORef Doc -> ItorCallback + getCategories ref itor key val exn = do + def <- bracket (pgf_print_category_internal val) free peekText + doc <- readIORef ref + writeIORef ref $ (doc $$ text def) + + ppAbsFuns p = unsafePerformIO $ do + ref <- newIORef empty + (allocaBytes (#size PgfItor) $ \itor -> + bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr -> + withForeignPtr (a_revision p) $ \c_revision -> do + (#poke PgfItor, fn) itor fptr + withPgfExn "functions" (pgf_iter_functions (a_db p) c_revision itor)) + readIORef ref + where + getFunctions :: IORef Doc -> ItorCallback + getFunctions ref itor key val exn = do + def <- bracket (pgf_print_function_internal val) free peekText + doc <- readIORef ref + writeIORef ref $ (doc $$ text def) + + ppConcr name c = + text "concrete" <+> text name <+> char '{' $$ + char '}' -- | The abstract language name is the name of the top-level -- abstract module diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 2a82b7aff..b8b7c7aea 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -95,6 +95,10 @@ foreign import ccall pgf_print_context :: CSize -> Ptr PgfTypeHypo -> Ptr PgfPri foreign import ccall "pgf_read_type" pgf_read_type :: Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Type) +foreign import ccall pgf_print_category_internal :: Ptr () -> IO (Ptr PgfText) + +foreign import ccall pgf_print_function_internal :: Ptr () -> IO (Ptr PgfText) + type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO () foreign import ccall "wrapper" wrapItorCallback :: Wrapper ItorCallback