From 070f63a049b33e1f9122536aab0f2a6256db45ad Mon Sep 17 00:00:00 2001 From: krangelov Date: Wed, 17 Nov 2021 14:03:04 +0100 Subject: [PATCH] complete showPGF --- src/runtime/c/pgf/pgf.cxx | 130 +++++++++++++++++++++- src/runtime/c/pgf/pgf.h | 29 ++++- src/runtime/c/pgf/printer.cxx | 83 ++++++++++++++ src/runtime/c/pgf/printer.h | 4 + src/runtime/haskell/PGF2.hsc | 74 ++++++++++-- src/runtime/haskell/PGF2/FFI.hsc | 18 ++- src/runtime/haskell/PGF2/Transactions.hsc | 21 +++- 7 files changed, 343 insertions(+), 16 deletions(-) diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 775adf75e..532316380 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/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 pgf = PgfDB::revision2pgf(revision); + + PgfText *startcat = (PgfText *) + alloca(sizeof(PgfText)+9); + startcat->size = 8; + strcpy(startcat->text, "startcat"); + + ref 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 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 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 lincat = o; + counts[0] = lincat->fields->len; +} + +PGF_API +PgfText *pgf_get_lincat_field_internal(object o, size_t i) +{ + ref lincat = o; + return &(**vector_elem(lincat->fields, i)); +} + +PGF_API +void pgf_get_lin_counts_internal(object o, size_t *counts) +{ + ref 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 lin = o; + ref 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 lin = o; + + PgfInternalMarshaller m; + PgfPrinter printer(NULL,0,&m); + + size_t n_seqs = lin->seqs->len / lin->res->len; + ref> 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>(n_fields); for (size_t i = 0; i < n_fields; i++) { + *vector_elem(lincat->fields, i) = textdup_db(fields[i]); } Namespace lincats = diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 865bd0cd0..b82807dd7 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/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, diff --git a/src/runtime/c/pgf/printer.cxx b/src/runtime/c/pgf/printer.cxx index 2643724db..0c13fa14a 100644 --- a/src/runtime/c/pgf/printer.cxx +++ b/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 ty, ref parg) +{ + efun(&ty->name); + puts("("); + lparam(parg->param); + puts(")"); +} + +void PgfPrinter::lparam(ref 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::get_tag(sym)) { + case PgfSymbolCat::tag: { + auto sym_cat = ref::untagged(sym); + nprintf(32, "<%ld,",sym_cat->d); + lparam(ref::from_ptr(&sym_cat->r)); + puts(">"); + break; + } + case PgfSymbolLit::tag: { + auto sym_lit = ref::untagged(sym); + nprintf(32, "{%ld,",sym_lit->d); + lparam(ref::from_ptr(&sym_lit->r)); + puts("}"); + break; + } + case PgfSymbolVar::tag: { + auto sym_var = ref::untagged(sym); + nprintf(64, "<%ld,$%ld>",sym_var->d, sym_var->r); + break; + } + case PgfSymbolKS::tag: { + auto sym_ks = ref::untagged(sym); + lstr(&sym_ks->token); + break; + } + case PgfSymbolKP::tag: { + auto sym_ks = ref::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) { } diff --git a/src/runtime/c/pgf/printer.h b/src/runtime/c/pgf/printer.h index b476c5026..4884710e2 100644 --- a/src/runtime/c/pgf/printer.h +++ b/src/runtime/c/pgf/printer.h @@ -50,6 +50,10 @@ public: void hypo(PgfTypeHypo *hypo, int prio); + void parg(ref ty, ref parg); + void lparam(ref 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); diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index d08852cc2..eb5bf801a 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/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 - writeIORef ref $ (doc $$ text def) + modifyIORef ref $ (\doc -> 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 - writeIORef ref $ (doc $$ text def) + modifyIORef ref (\doc -> 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 diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index b8b7c7aea..94c34e9ff 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/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 () diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 4e0b4ecce..82acbe8fa 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/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 -> - pgf_create_lincat c_db c_abstr c_revision c_name (fromIntegral (length fields)) c_exn + let n_fields = length fields + 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 - pokeElemOff c_terms 0 (fromIntegral index) + pokeTerms c_terms ((factor,var):terms) = do + 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 ->