GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-21 18:59:32 -06:00
Code Issues Packages Projects Releases Wiki Activity

complete showPGF

Browse Source
This commit is contained in:
krangelov
2021-11-17 14:03:04 +01:00
parent 6295b32405
commit 070f63a049
7 changed files with 343 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

74
src/runtime/haskell/PGF2.hsc
View File

@@ -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

18
src/runtime/haskell/PGF2/FFI.hsc
View File

@@ -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 ()

21
src/runtime/haskell/PGF2/Transactions.hsc
View File

@@ -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 ->