progress on showPGF

src/runtime/c/pgf/expr.cxx

@@ -222,6 +222,79 @@ void PgfDBUnmarshaller::free_ref(object x)
     PgfDB::free(ref<void>::untagged(x));
 }
 
+PgfLiteral PgfInternalMarshaller::match_lit(PgfUnmarshaller *u, PgfLiteral l)
+{
+    switch (ref<PgfLiteral>::get_tag(l)) {
+    case PgfLiteralInt::tag: {
+        auto lint = ref<PgfLiteralInt>::untagged(l);
+        return u->lint(lint->size, lint->val);
+    }
+    case PgfLiteralFlt::tag: {
+        return u->lflt(ref<PgfLiteralFlt>::untagged(l)->val);
+    }
+    case PgfLiteralStr::tag: {
+        return u->lstr(&ref<PgfLiteralStr>::untagged(l)->val);
+    }
+	default:
+		throw pgf_error("Unknown literal tag");
+    }
+}
+
+PgfExpr PgfInternalMarshaller::match_expr(PgfUnmarshaller *u, PgfExpr e)
+{
+    switch (ref<PgfExpr>::get_tag(e)) {
+    case PgfExprAbs::tag: {
+        auto eabs = ref<PgfExprAbs>::untagged(e);
+        return u->eabs(eabs->bind_type,&eabs->name,eabs->body);
+    }
+    case PgfExprApp::tag: {
+        auto eapp = ref<PgfExprApp>::untagged(e);
+        return u->eapp(eapp->fun,eapp->arg);
+    }
+    case PgfExprLit::tag: {
+        auto elit = ref<PgfExprLit>::untagged(e);
+        return u->elit(elit->lit);
+    }
+    case PgfExprMeta::tag: {
+        return u->emeta(ref<PgfExprMeta>::untagged(e)->id);
+    }
+	case PgfExprFun::tag: {
+        return u->efun(&ref<PgfExprFun>::untagged(e)->name);
+    }
+	case PgfExprVar::tag: {
+        return u->evar(ref<PgfExprVar>::untagged(e)->var);
+	}
+	case PgfExprTyped::tag: {
+        auto etyped = ref<PgfExprTyped>::untagged(e);
+        return u->etyped(etyped->expr,etyped->type.as_object());
+	}
+	case PgfExprImplArg::tag: {
+        auto eimpl = ref<PgfExprImplArg>::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<PgfDTyp> 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;

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;

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<PgfAbsCat> 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<PgfAbsFun> 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,

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,

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);

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

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