diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index e97ffe525..cc621b725 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -485,6 +485,28 @@ void pgf_iter_concretes(PgfDB *db, PgfRevision revision, } PGF_API_END } +PGF_API +PgfConcrRevision pgf_get_concrete(PgfDB *db, PgfRevision revision, + PgfText *name, PgfExn *err) +{ + PGF_API_BEGIN { + size_t txn_id; + + DB_scope scope(db, READER_SCOPE); + ref pgf = db->revision2pgf(revision, &txn_id); + + ref concr = + namespace_lookup(pgf->concretes, name); + if (concr == 0) + return 0; + + db->ref_count++; + return db->register_revision(concr.tagged(), txn_id); + } PGF_API_END + + return 0; +} + PGF_API PgfType pgf_start_cat(PgfDB *db, PgfRevision revision, PgfUnmarshaller *u, diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 2022e00a3..3c41c6e26 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -347,6 +347,10 @@ PGF_API_DECL void pgf_iter_concretes(PgfDB *db, PgfRevision revision, PgfItor *itor, PgfExn *err); +PGF_API_DECL +PgfConcrRevision pgf_get_concrete(PgfDB *db, PgfRevision revision, + PgfText *name, PgfExn *err); + PGF_API_DECL PgfType pgf_start_cat(PgfDB *db, PgfRevision revision, PgfUnmarshaller *u, diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index da25c08bb..6870a725f 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -76,7 +76,7 @@ module PGF2 (-- * PGF graphvizWordAlignment, graphvizLRAutomaton, -- * Concrete syntax - ConcName,Concr,languages,concreteName,languageCode,concreteFlag, + ConcName,Concr,languages,language,concreteName,languageCode,concreteFlag, -- ** Linearization linearize, linearizeAll, tabularLinearize, tabularLinearizeAll, @@ -299,6 +299,16 @@ languages p = unsafePerformIO $ do fptr <- newForeignPtrEnv pgf_free_concr_revision (a_db p) (castPtr c_revision) writeIORef ref (Map.insert name (Concr (a_db p) fptr) concrs) +language :: PGF -> ConcName -> Maybe Concr +language p name = unsafePerformIO $ + (withForeignPtr (a_revision p) $ \c_revision -> + withText name $ \c_name -> do + res <- withPgfExn "language" (pgf_get_concrete (a_db p) c_revision c_name) + if res == nullPtr + then return Nothing + else do fptr <- newForeignPtrEnv pgf_free_concr_revision (a_db p) res + return (Just (Concr (a_db p) fptr))) + showPGF :: PGF -> String showPGF p = render (text "abstract" <+> ppAbstractName p <+> char '{' $$ diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 274cca3af..3278c2f32 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -178,6 +178,8 @@ foreign import ccall pgf_iter_categories :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor foreign import ccall pgf_iter_concretes :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO () +foreign import ccall pgf_get_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfItor -> Ptr PgfExn -> IO (Ptr Concr) + foreign import ccall pgf_start_cat :: Ptr PgfDB -> Ptr PGF -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type) foreign import ccall pgf_category_context :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfTypeHypo)