complete showPGF

src/runtime/c/pgf/pgf.cxx

@@ -718,6 +718,33 @@ PgfText *pgf_print_category_internal(object o)
     return printer.get_text();
 }
 
+PGF_API
+PgfText *pgf_print_start_cat_internal(PgfDB *db, PgfRevision revision, PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, READER_SCOPE);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
+
+        PgfText *startcat = (PgfText *)
+            alloca(sizeof(PgfText)+9);
+        startcat->size = 8;
+        strcpy(startcat->text, "startcat");
+
+        ref<PgfFlag> flag =
+            namespace_lookup(pgf->abstract.aflags, startcat);
+
+        if (flag != 0) {
+            PgfInternalMarshaller m;
+            PgfPrinter printer(NULL,0,&m);
+            printer.puts("startcat = ");
+            m.match_lit(&printer, flag->value);
+            return printer.get_text();
+        }
+    } PGF_API_END
+
+    return NULL;
+}
+
 PGF_API
 PgfText *pgf_print_function_internal(object o)
 {
@@ -735,6 +762,105 @@ PgfText *pgf_print_function_internal(object o)
     return printer.get_text();
 }
 
+PGF_API
+void pgf_iter_lincats(PgfDB *db, PgfConcrRevision cnc_revision,
+                      PgfItor *itor, PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, READER_SCOPE);
+        ref<PgfConcr> concr = PgfDB::revision2concr(cnc_revision);
+
+        namespace_iter(concr->lincats, itor, err);
+    } PGF_API_END
+}
+
+PGF_API
+void pgf_iter_lins(PgfDB *db, PgfConcrRevision cnc_revision,
+                   PgfItor *itor, PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, READER_SCOPE);
+        ref<PgfConcr> concr = PgfDB::revision2concr(cnc_revision);
+
+        namespace_iter(concr->lins, itor, err);
+    } PGF_API_END
+}
+
+PGF_API
+void pgf_get_lincat_counts_internal(object o, size_t *counts)
+{
+    ref<PgfConcrLincat> lincat = o;
+    counts[0] = lincat->fields->len;
+}
+
+PGF_API
+PgfText *pgf_get_lincat_field_internal(object o, size_t i)
+{
+    ref<PgfConcrLincat> lincat = o;
+    return &(**vector_elem(lincat->fields, i));
+}
+
+PGF_API
+void pgf_get_lin_counts_internal(object o, size_t *counts)
+{
+    ref<PgfConcrLin> lin = o;
+    counts[0] = lin->res->len;
+    counts[1] = lin->seqs->len / lin->res->len;
+}
+
+PGF_API
+PgfText *pgf_print_lin_sig_internal(object o, size_t i)
+{
+    ref<PgfConcrLin> lin = o;
+    ref<PgfDTyp> ty = lin->absfun->type;
+
+    PgfInternalMarshaller m;
+    PgfPrinter printer(NULL,0,&m);
+
+    printer.efun(&lin->name);
+    printer.puts(" : ");
+
+    size_t n_args = lin->args->len / lin->res->len;
+    for (size_t j = 0; j < n_args; j++) {
+        if (j > 0)
+            printer.puts(" * ");
+
+        printer.parg(vector_elem(ty->hypos, j)->type,
+                     vector_elem(lin->args, i*n_args + j));
+    }
+
+    if (n_args > 0)
+        printer.puts(" -> ");
+
+    printer.efun(&ty->name);
+    puts("(");
+    printer.lparam(*vector_elem(lin->res, i));
+    puts(")");
+
+    return printer.get_text();
+}
+
+PGF_API
+PgfText *pgf_print_lin_seq_internal(object o, size_t i, size_t j)
+{
+    ref<PgfConcrLin> lin = o;
+
+    PgfInternalMarshaller m;
+    PgfPrinter printer(NULL,0,&m);
+
+    size_t n_seqs = lin->seqs->len / lin->res->len;
+    ref<Vector<PgfSymbol>> syms = *vector_elem(lin->seqs, i*n_seqs + j);
+
+    for (size_t k = 0; k < syms->len; k++) {
+        if (k > 0)
+            printer.puts(" ");
+
+        printer.symbol(*vector_elem(syms, k));
+    }
+
+    return printer.get_text();
+}
+
 PGF_API
 PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision,
                                PgfText *name,
@@ -1200,7 +1326,8 @@ public:
 PGF_API
 void pgf_create_lincat(PgfDB *db,
                        PgfRevision revision, PgfConcrRevision cnc_revision,
-                       PgfText *name, size_t n_fields, PgfExn *err)
+                       PgfText *name, size_t n_fields, PgfText **fields,
+                       PgfExn *err)
 {
     PGF_API_BEGIN {
         DB_scope scope(db, WRITER_SCOPE);
@@ -1221,6 +1348,7 @@ void pgf_create_lincat(PgfDB *db,
         lincat->fields = vector_new<ref<PgfText>>(n_fields);
 
         for (size_t i = 0; i < n_fields; i++) {
+            *vector_elem(lincat->fields, i) = textdup_db(fields[i]);
         }
 
         Namespace<PgfConcrLincat> lincats =

src/runtime/c/pgf/pgf.h

@@ -371,12 +371,38 @@ PgfText *pgf_print_context(size_t n_hypos, PgfTypeHypo *hypos,
 PGF_API_DECL
 PgfType pgf_read_type(PgfText *input, PgfUnmarshaller *u);
 
+PGF_API
+PgfText *pgf_print_start_cat_internal(PgfDB *db, PgfRevision revision, PgfExn *err);
+
 PGF_API_DECL
 PgfText *pgf_print_category_internal(object o);
 
 PGF_API_DECL
 PgfText *pgf_print_function_internal(object o);
 
+PGF_API_DECL
+void pgf_iter_lincats(PgfDB *db, PgfConcrRevision cnc_revision,
+                      PgfItor *itor, PgfExn *err);
+
+PGF_API_DECL
+void pgf_iter_lins(PgfDB *db, PgfConcrRevision cnc_revision,
+                   PgfItor *itor, PgfExn *err);
+
+PGF_API_DECL
+void pgf_get_lincat_counts_internal(object o, size_t *counts);
+
+PGF_API_DECL
+PgfText *pgf_get_lincat_field_internal(object o, size_t i);
+
+PGF_API_DECL
+void pgf_get_lin_counts_internal(object o, size_t *counts);
+
+PGF_API_DECL
+PgfText *pgf_print_lin_sig_internal(object o, size_t i);
+
+PGF_API_DECL
+PgfText *pgf_print_lin_seq_internal(object o, size_t i, size_t j);
+
 PGF_API_DECL
 PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision,
                                PgfText *name,
@@ -432,7 +458,8 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
 PGF_API_DECL
 void pgf_create_lincat(PgfDB *db,
                        PgfRevision revision, PgfConcrRevision cnc_revision,
-                       PgfText *name, size_t n_fields, PgfExn *err);
+                       PgfText *name, size_t n_fields, PgfText **fields,
+                       PgfExn *err);
 
 PGF_API_DECL
 void pgf_drop_lincat(PgfDB *db, PgfConcrRevision revision,

src/runtime/c/pgf/printer.cxx

@@ -433,6 +433,89 @@ PgfType PgfPrinter::dtyp(size_t n_hypos, PgfTypeHypo *hypos,
     return 0;
 }
 
+void PgfPrinter::parg(ref<PgfDTyp> ty, ref<PgfPArg> parg)
+{
+    efun(&ty->name);
+    puts("(");
+    lparam(parg->param);
+    puts(")");
+}
+
+void PgfPrinter::lparam(ref<PgfLParam> lparam)
+{
+    if (lparam->i0 != 0 || lparam->n_terms == 0)
+        nprintf(32,"%ld",lparam->i0);
+    for (size_t k = 0; k < lparam->n_terms; k++) {
+        if (lparam->i0 != 0 || k > 0)
+            puts("+");
+        if (lparam->terms[k].factor != 1) {
+            nprintf(32,"%ld",lparam->terms[k].factor);
+            puts("*");
+        }
+
+        char vars[] = "ijklmnopqr";
+        size_t i = lparam->terms[k].var / sizeof(vars);
+        size_t j = lparam->terms[k].var % sizeof(vars);
+
+        if (i == 0)
+            nprintf(32,"%c",vars[j]);
+        else
+            nprintf(32,"%c%ld",vars[j],i);
+    }
+}
+
+void PgfPrinter::symbol(PgfSymbol sym)
+{
+    switch (ref<PgfSymbol>::get_tag(sym)) {
+	case PgfSymbolCat::tag: {
+        auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
+        nprintf(32, "<%ld,",sym_cat->d);
+        lparam(ref<PgfLParam>::from_ptr(&sym_cat->r));
+        puts(">");
+		break;
+	}
+	case PgfSymbolLit::tag: {
+        auto sym_lit = ref<PgfSymbolLit>::untagged(sym);
+        nprintf(32, "{%ld,",sym_lit->d);
+        lparam(ref<PgfLParam>::from_ptr(&sym_lit->r));
+        puts("}");
+		break;
+	}
+	case PgfSymbolVar::tag: {
+        auto sym_var = ref<PgfSymbolVar>::untagged(sym);
+        nprintf(64, "<%ld,$%ld>",sym_var->d, sym_var->r);
+		break;
+	}
+	case PgfSymbolKS::tag: {
+        auto sym_ks = ref<PgfSymbolKS>::untagged(sym);
+        lstr(&sym_ks->token);
+		break;
+	}
+	case PgfSymbolKP::tag: {
+        auto sym_ks = ref<PgfSymbolKP>::untagged(sym);
+		break;
+	}
+	case PgfSymbolBIND::tag:
+        puts("BIND");
+        break;
+	case PgfSymbolSOFTBIND::tag:
+        puts("SOFT_BIND");
+        break;
+	case PgfSymbolNE::tag:
+        puts("nonExist");
+        break;
+	case PgfSymbolSOFTSPACE::tag:
+        puts("SOFT_SPACE");
+        break;
+	case PgfSymbolCAPIT::tag:
+        puts("CAPIT");
+        break;
+	case PgfSymbolALLCAPIT::tag:
+        puts("ALL_CAPIT");
+        break;
+	}
+}
+
 void PgfPrinter::free_ref(object x)
 {
 }

src/runtime/c/pgf/printer.h

@@ -50,6 +50,10 @@ public:
 
     void hypo(PgfTypeHypo *hypo, int prio);
 
+    void parg(ref<PgfDTyp> ty, ref<PgfPArg> parg);
+    void lparam(ref<PgfLParam> lparam);
+    void symbol(PgfSymbol sym);
+
     virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body);
     virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg);
     virtual PgfExpr elit(PgfLiteral lit);

src/runtime/haskell/PGF2.hsc

@@ -93,6 +93,7 @@ import PGF2.FFI
 
 import Foreign
 import Foreign.C
+import Control.Monad(forM,forM_)
 import Control.Exception(mask_,bracket)
 import System.IO.Unsafe(unsafePerformIO)
 import System.Random
@@ -170,11 +171,21 @@ writePGF fpath p =
 showPGF :: PGF -> String
 showPGF p =
   render (text "abstract" <+> ppAbstractName p <+> char '{' $$
-          nest 2 (ppAbsCats p $$
+          nest 2 (ppStartCat p $$
+                  ppAbsCats p $$
                   ppAbsFuns p) $$
           char '}' $$
           Map.foldrWithKey (\name concr doc -> ppConcr name concr $$ doc) empty (languages p))
   where
+    ppStartCat p =
+      unsafePerformIO $
+      withForeignPtr (a_revision p) $ \c_revision -> do
+        c_text <- withPgfExn "showPGF" (pgf_print_start_cat_internal (a_db p) c_revision)
+        if c_text == nullPtr
+          then return empty
+          else do s <- peekText c_text
+                  return (text "flags" <+> text s)
+
     ppAbstractName p =
       unsafePerformIO $
       withForeignPtr (a_revision p) $ \c_revision ->
@@ -188,14 +199,13 @@ showPGF p =
        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))
+         withPgfExn "showPGF" (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
+          modifyIORef ref $ (\doc -> doc $$ text def)
-          writeIORef ref $ (doc $$ text def)
 
     ppAbsFuns p = unsafePerformIO $ do
       ref <- newIORef empty
@@ -203,19 +213,69 @@ showPGF p =
        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))
+         withPgfExn "showPGF" (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
+          modifyIORef ref (\doc -> doc $$ text def)
-          writeIORef ref $ (doc $$ text def)
 
     ppConcr name c =
       text "concrete" <+> text name <+> char '{' $$
+      nest 2 (ppLincats c $$
+              ppLins c) $$
       char '}'
 
+    ppLincats c = unsafePerformIO $ do
+      ref <- newIORef empty
+      (allocaBytes (#size PgfItor) $ \itor ->
+       bracket (wrapItorCallback (getLincats ref)) freeHaskellFunPtr $ \fptr ->
+       withForeignPtr (c_revision c) $ \c_revision -> do
+         (#poke PgfItor, fn) itor fptr
+         withPgfExn "showPGF" (pgf_iter_lincats (a_db p) c_revision itor))
+      readIORef ref
+      where
+        getLincats :: IORef Doc -> ItorCallback
+        getLincats ref itor key val exn = do
+          name   <- bracket (pgf_print_ident key) free $ \c_text -> do
+                      peekText c_text
+          fields <- allocaBytes (1*(#size size_t)) $ \pcounts -> do
+                      pgf_get_lincat_counts_internal val pcounts
+                      n_fields <- peekElemOff pcounts 0
+                      forM [0..n_fields-1] $ \i -> do
+                        pgf_get_lincat_field_internal val i >>= peekText
+          let def = text "lincat" <+> (text name <+> char '=' <+> char '{' $$
+                                       nest 2 (vcat (map text fields)) $$
+                                       char '}')
+          modifyIORef ref $ (\doc -> doc $$ def)
+
+    ppLins c = unsafePerformIO $ do
+      ref <- newIORef empty
+      (allocaBytes (#size PgfItor) $ \itor ->
+       bracket (wrapItorCallback (getLins ref)) freeHaskellFunPtr $ \fptr ->
+       withForeignPtr (c_revision c) $ \c_revision -> do
+         (#poke PgfItor, fn) itor fptr
+         withPgfExn "showPGF" (pgf_iter_lins (a_db p) c_revision itor))
+      readIORef ref
+      where
+        getLins :: IORef Doc -> ItorCallback
+        getLins ref itor key val exn =
+          allocaBytes (2*(#size size_t)) $ \pcounts -> do
+            pgf_get_lin_counts_internal val pcounts
+            n_prods <- peekElemOff pcounts 0
+            n_seqs  <- peekElemOff pcounts 1
+            forM_ [0..n_prods-1] $ \i -> do
+              sig <- bracket (pgf_print_lin_sig_internal val i) free $ \c_text -> do
+                       fmap text (peekText c_text)
+              syms <- forM [0..n_seqs-1] $ \j ->
+                        bracket (pgf_print_lin_seq_internal val i j) free $ \c_text -> do
+                          fmap text (peekText c_text)
+              let def = text "lin" <+> (sig <+> char '=' <+> char '{' $$
+                                        nest 2 (vcat syms) $$
+                                        char '}')
+              modifyIORef ref $ (\doc -> doc $$ def)
+
 -- | The abstract language name is the name of the top-level
 -- abstract module
 abstractName :: PGF -> AbsName

src/runtime/haskell/PGF2/FFI.hsc

@@ -95,10 +95,26 @@ 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_start_cat_internal :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO (Ptr PgfText)
+
 foreign import ccall pgf_print_category_internal :: Ptr () -> IO (Ptr PgfText)
 
 foreign import ccall pgf_print_function_internal :: Ptr () -> IO (Ptr PgfText)
 
+foreign import ccall pgf_iter_lincats :: Ptr PgfDB -> Ptr Concr -> Ptr PgfItor -> Ptr PgfExn -> IO ()
+
+foreign import ccall pgf_iter_lins :: Ptr PgfDB -> Ptr Concr -> Ptr PgfItor -> Ptr PgfExn -> IO ()
+
+foreign import ccall pgf_get_lincat_counts_internal :: Ptr () -> Ptr CSize -> IO ()
+
+foreign import ccall pgf_get_lincat_field_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
+
+foreign import ccall pgf_get_lin_counts_internal :: Ptr () -> Ptr CSize -> IO ()
+
+foreign import ccall pgf_print_lin_sig_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
+
+foreign import ccall pgf_print_lin_seq_internal :: Ptr () -> CSize -> CSize -> IO (Ptr PgfText)
+
 type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO ()
 
 foreign import ccall "wrapper" wrapItorCallback :: Wrapper ItorCallback
@@ -163,7 +179,7 @@ foreign import ccall "dynamic" callLinBuilder4 :: Dynamic (Ptr PgfLinBuilderIfac
 
 foreign import ccall "dynamic" callLinBuilder5 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfText -> Ptr PgfExn -> IO ())
 
-foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
 

src/runtime/haskell/PGF2/Transactions.hsc

@@ -216,8 +216,17 @@ data Production = Production [PArg] LParam [[Symbol]]
 
 createLincat :: Cat -> [String] -> Transaction Concr ()
 createLincat name fields = Transaction $ \c_db c_abstr c_revision c_exn ->
-  withText name $ \c_name ->
+  let n_fields = length fields
-    pgf_create_lincat c_db c_abstr c_revision c_name (fromIntegral (length fields)) c_exn
+  in withText name $ \c_name ->
+     allocaBytes (n_fields*(#size PgfText*)) $ \c_fields ->
+     withTexts c_fields 0 fields $
+       pgf_create_lincat c_db c_abstr c_revision c_name (fromIntegral n_fields) c_fields c_exn
+  where
+    withTexts p i []     f = f
+    withTexts p i (s:ss) f =
+      withText s $ \c_s -> do
+        pokeElemOff p i c_s
+        withTexts p (i+1) ss f
 
 dropLincat :: Cat -> Transaction Concr ()
 dropLincat name = Transaction $ \c_db _ c_revision c_exn ->
@@ -287,17 +296,17 @@ createLin name prods = Transaction $ \c_db c_abstr c_revision c_exn ->
       callLinBuilder0 fun c_builder c_exn
 
     callLParam f (LParam i0 terms) c_exn =
-      allocaBytes ((#size size_t)*2*n_terms) $ \c_terms -> do
+      allocaBytes (n_terms*2*(#size size_t)) $ \c_terms -> do
         pokeTerms c_terms terms
         f (fromIntegral i0) (fromIntegral n_terms) c_terms c_exn
       where
         n_terms = length terms
 
         pokeTerms c_terms []                  = return ()
-        pokeTerms c_terms ((index,var):terms) = do
+        pokeTerms c_terms ((factor,var):terms) = do
-          pokeElemOff c_terms 0 (fromIntegral index)
+          pokeElemOff c_terms 0 (fromIntegral factor)
           pokeElemOff c_terms 1 (fromIntegral var)
-          pokeTerms (c_terms `plusPtr` ((#size size_t) * 2)) terms
+          pokeTerms (c_terms `plusPtr` (2*(#size size_t))) terms
 
 dropLin :: Fun -> Transaction Concr ()
 dropLin name = Transaction $ \c_db _ c_revision c_exn ->