From bbff79aaa3103c011b779f8f204e2b50d1f5b26e Mon Sep 17 00:00:00 2001 From: krangelov Date: Fri, 3 Dec 2021 16:49:36 +0100 Subject: [PATCH] added API for print names --- src/compiler/GF/Compile/GeneratePMCFG.hs | 13 +++++--- src/compiler/GF/Compile/GrammarToPGF.hs | 10 +++++- src/runtime/c/pgf/pgf.cxx | 36 ++++++++++++++++++++++ src/runtime/c/pgf/pgf.h | 8 +++++ src/runtime/haskell/PGF2.hsc | 9 +++++- src/runtime/haskell/PGF2/FFI.hsc | 4 +++ src/runtime/haskell/PGF2/Transactions.hsc | 7 +++++ src/runtime/haskell/tests/basic.pgf | Bin 341 -> 349 bytes src/runtime/haskell/tests/basic.pmcfg | 4 +-- src/runtime/haskell/tests/basic_cnc.gf | 3 ++ 10 files changed, 86 insertions(+), 8 deletions(-) diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 6efe59fe1..1422d6176 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -32,10 +32,15 @@ generatePMCFG opts cwd gr cmo@(cm,cmi) = do js <- mapM (addPMCFG opts cwd gr' cmi) (Map.toList (jments cmi)) return (cm,cmi{jments = (Map.fromAscList js)}) -addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) = - checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ do - rules <- pmcfgForm gr term ctxt val - return (id,CncFun mty mlin mprn (Just rules)) +addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) = do + rules <- checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ + pmcfgForm gr term ctxt val + mprn <- case mprn of + Nothing -> return Nothing + Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do + prn <- normalForm gr prn + return (Just (L loc prn)) + return (id,CncFun mty mlin mprn (Just rules)) addPMCFG opts cwd gr cmi id_info = return id_info pmcfgForm :: Grammar -> Term -> Context -> Type -> Check [Production] diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 10eedb572..5dc7172d1 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -90,10 +90,18 @@ grammar2PGF opts gr am probs = do createLincat (i2i c) (type2fields gr ty) createCncCats _ = return () - createCncFuns ((m,f),CncFun _ _ _ (Just prods)) = do + createCncFuns ((m,f),CncFun _ _ mprn (Just prods)) = do createLin (i2i f) prods + case mprn of + Nothing -> return () + Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn)) createCncFuns _ = return () + term2tokens (K tok) = [tok] + term2tokens (C t1 t2) = term2tokens t1 ++ term2tokens t2 + term2tokens (Typed t _) = term2tokens t + term2tokens _ = [] + i2i :: Ident -> String i2i = showIdent diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 08204a9bb..1a1f1f4c7 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -1889,6 +1889,42 @@ void pgf_bracketed_linearize(PgfDB *db, PgfConcrRevision revision, } PGF_API_END } +PGF_API +PgfText *pgf_get_printname(PgfDB *db, PgfConcrRevision revision, + PgfText *fun, PgfExn* err) +{ + PGF_API_BEGIN { + DB_scope scope(db, READER_SCOPE); + + ref concr = PgfDB::revision2concr(revision); + PgfText *printname = namespace_lookup(concr->printnames, fun)->printname; + return textdup(printname); + } PGF_API_END + + return NULL; +} + +PGF_API +void pgf_set_printname(PgfDB *db, PgfConcrRevision revision, + PgfText *fun, PgfText *name, PgfExn* err) +{ + PGF_API_BEGIN { + DB_scope scope(db, WRITER_SCOPE); + + ref concr = PgfDB::revision2concr(revision); + + ref printname = PgfDB::malloc(fun->size+1); + printname->ref_count = 1; + memcpy(&printname->name, fun, sizeof(PgfText)+fun->size+1); + printname->printname = textdup_db(name); + + Namespace printnames = + namespace_insert(concr->printnames, printname); + namespace_release(concr->printnames); + concr->printnames = printnames; + } PGF_API_END +} + PGF_API PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision, PgfText *name, diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index ad7ab0243..249687f26 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -630,6 +630,14 @@ void pgf_bracketed_linearize(PgfDB *db, PgfConcrRevision revision, PgfLinearizationOutputIface *out, PgfExn* err); +PGF_API_DECL +PgfText *pgf_get_printname(PgfDB *db, PgfConcrRevision revision, + PgfText *fun, PgfExn* err); + +PGF_API_DECL +void pgf_set_printname(PgfDB *db, PgfConcrRevision revision, + PgfText *fun, PgfText *name, PgfExn* err); + PGF_API_DECL PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision, PgfText *name, diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 89d9897ba..a20fed383 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -415,7 +415,14 @@ concreteFlag c name = return (Just lit) printName :: Concr -> Fun -> Maybe String -printName lang fun = error "TODO: printName" +printName c fun = + unsafePerformIO $ + withText fun $ \c_fun -> + withForeignPtr (c_revision c) $ \c_revision -> + bracket (withPgfExn "printName" (pgf_get_printname (c_db c) c_revision c_fun)) free $ \c_name -> do + if c_name /= nullPtr + then fmap Just $ peekText c_name + else return Nothing alignWords :: Concr -> Expr -> [(String, [Int])] alignWords = error "TODO: alignWords" diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index d5b1b2676..60046a44a 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -210,6 +210,10 @@ foreign import ccall "wrapper" wrapSymbol2 :: Wrapper (Ptr PgfLinearizationOutpu foreign import ccall "wrapper" wrapSymbol3 :: Wrapper (Ptr PgfLinearizationOutputIface -> CInt -> IO ()) +foreign import ccall pgf_get_printname :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfText) + +foreign import ccall pgf_set_printname :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfText -> Ptr PgfExn -> IO () + foreign import ccall pgf_get_global_flag :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal) foreign import ccall pgf_set_global_flag :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO () diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index cd25c2aac..8781be269 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -24,6 +24,7 @@ module PGF2.Transactions , dropLincat , createLin , dropLin + , setPrintName ) where import PGF2.FFI @@ -344,3 +345,9 @@ dropLin :: Fun -> Transaction Concr () dropLin name = Transaction $ \c_db _ c_revision c_exn -> withText name $ \c_name -> pgf_drop_lin c_db c_revision c_name c_exn + +setPrintName :: Fun -> String -> Transaction Concr () +setPrintName fun name = Transaction $ \c_db _ c_revision c_exn -> + withText fun $ \c_fun -> + withText name $ \c_name -> do + withPgfExn "setPrintName" (pgf_set_printname c_db c_revision c_fun c_name) diff --git a/src/runtime/haskell/tests/basic.pgf b/src/runtime/haskell/tests/basic.pgf index eacd46800ca86565f333cbf720a640f4f69b4f00..cdb429166faf04340fd32c4f0e92bf0019fc1a43 100644 GIT binary patch delta 51 zcmcc0beCxZC!;I_BO?P71Bhf`U|`P7OJQaJ0Y*lU&}216Jx(UZVn##8Dn S(0) = [ + lin c : ∀{i<2} . N(i) -> S(0) = [ <0,0> ] - lin ind : ∀{j<2} . P(0) * P(0) * N(j) -> P(0) = [ + lin ind : ∀{i<2} . P(0) * P(0) * N(i) -> P(0) = [ ] lin s : N(0) -> N(0) = [ <0,0> "+" "1" diff --git a/src/runtime/haskell/tests/basic_cnc.gf b/src/runtime/haskell/tests/basic_cnc.gf index b2995dcfe..40c42f3e6 100644 --- a/src/runtime/haskell/tests/basic_cnc.gf +++ b/src/runtime/haskell/tests/basic_cnc.gf @@ -3,6 +3,9 @@ concrete basic_cnc of basic = open Prelude in { lincat N = {s : Str; is_zero : Bool} ; lincat S = Str ; +printname fun z = "0" ; +printname fun s = "1" ; + lin z = {s="0"; is_zero=True} ; s n = { s = case n.is_zero of {