diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 6d6d517de..ce0fe17a2 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -280,6 +280,36 @@ end: fclose(out); } +#ifdef _GNU_SOURCE +PGF_API +void pgf_write_pgf_cookie + (void *cookie, cookie_io_functions_t *io_funcs, + PgfDB *db, PgfRevision revision, + PgfText **langs, // null terminated list or null + PgfExn* err) +{ + FILE *out = NULL; + + PGF_API_BEGIN { + out = fopencookie(cookie, "wb", *io_funcs); + if (!out) { + throw pgf_systemerror(errno, ""); + } + + { + DB_scope scope(db, READER_SCOPE); + ref pgf = db->revision2pgf(revision); + + PgfWriter wtr(langs, out); + wtr.write_pgf(pgf); + } + } PGF_API_END + + if (out != NULL) + fclose(out); +} +#endif + PGF_API const char *pgf_file_path(PgfDB *db) { diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index fdad8e59a..70109a2da 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -291,6 +291,15 @@ void pgf_write_pgf(const char* fpath, PgfText **langs, // null terminated list or null PgfExn* err); +#ifdef _GNU_SOURCE +PGF_API_DECL +void pgf_write_pgf_cookie + (void *cookie, cookie_io_functions_t *io_funcs, + PgfDB *db, PgfRevision revision, + PgfText **langs, // null terminated list or null + PgfExn* err); +#endif + PGF_API_DECL const char *pgf_file_path(PgfDB *db); diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 13b8bd28d..39419d477 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -16,6 +16,9 @@ module PGF2 (-- * PGF PGF,readPGF,bootNGF,readNGF,newNGF,writePGF,showPGF, readPGFWithProbs, bootNGFWithProbs, +#ifdef __linux__ + writePGF_, +#endif -- * Abstract syntax AbsName,abstractName,globalFlag,abstractFlag, @@ -109,6 +112,10 @@ import Data.Char(isUpper,isSpace,isPunctuation) import Data.Maybe(maybe) import Text.PrettyPrint +#ifdef __linux__ +#define _GNU_SOURCE +#include +#endif #include -- | Reads a PGF file and keeps it in memory. @@ -201,6 +208,39 @@ writePGF fpath p mb_langs = withLangs clangs [] f = withArray0 nullPtr (reverse clangs) f withLangs clangs (lang:langs) f = withText lang $ \clang -> withLangs (clang:clangs) langs f +#ifdef __linux__ +writePGF_ :: (Ptr Word8 -> CSize -> IO CSize) -> PGF -> Maybe [ConcName] -> IO () +writePGF_ callback p mb_langs = + allocaBytes (#size cookie_io_functions_t) $ \io_functions -> + withForeignPtr (a_revision p) $ \c_revision -> + maybe (\f -> f nullPtr) (withLangs []) mb_langs $ \c_langs -> do + cookie <- fmap castStablePtrToPtr (newStablePtr callback) + (#poke cookie_io_functions_t, read) io_functions nullPtr + (#poke cookie_io_functions_t, write) io_functions cookie_write_ptr + (#poke cookie_io_functions_t, seek) io_functions nullPtr + (#poke cookie_io_functions_t, close) io_functions cookie_close_ptr + withPgfExn "writePGF_" (pgf_write_pgf_cookie cookie io_functions (a_db p) c_revision c_langs) + where + withLangs clangs [] f = withArray0 nullPtr (reverse clangs) f + withLangs clangs (lang:langs) f = withText lang $ \clang -> withLangs (clang:clangs) langs f +#endif + +cookie_write :: Ptr () -> Ptr Word8 -> CSize -> IO CSize +cookie_write cookie buf size = do + callback <- deRefStablePtr (castPtrToStablePtr cookie) + callback buf size + +foreign export ccall cookie_write :: Ptr () -> Ptr Word8 -> CSize -> IO CSize +foreign import ccall "&cookie_write" cookie_write_ptr :: FunPtr (Ptr () -> Ptr Word8 -> CSize -> IO CSize) + +cookie_close :: Ptr () -> IO CInt +cookie_close cookie = do + freeStablePtr (castPtrToStablePtr cookie) + return 0 + +foreign export ccall cookie_close :: Ptr () -> IO CInt +foreign import ccall "&cookie_close" cookie_close_ptr :: FunPtr (Ptr () -> IO CInt) + 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 9086b6855..50e93da86 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -17,6 +17,10 @@ import System.IO.Unsafe(unsafePerformIO) import PGF2.Expr +#ifdef __linux__ +#define _GNU_SOURCE +#include +#endif #include type AbsName = String -- ^ Name of abstract syntax @@ -52,6 +56,7 @@ data PgfCohortsCallback data PgfPhrasetableIds data PgfExprEnum data PgfAlignmentPhrase +data CookieIOFunctions type Wrapper a = a -> IO (FunPtr a) type Dynamic a = FunPtr a -> a @@ -81,6 +86,10 @@ foreign import ccall pgf_merge_pgf :: Ptr PgfDB -> Ptr PGF -> CString -> Ptr Pgf foreign import ccall pgf_write_pgf :: CString -> Ptr PgfDB -> Ptr PGF -> Ptr (Ptr PgfText) -> Ptr PgfExn -> IO () +#ifdef _GNU_SOURCE +foreign import ccall pgf_write_pgf_cookie :: Ptr () -> Ptr CookieIOFunctions -> Ptr PgfDB -> Ptr PGF -> Ptr (Ptr PgfText) -> Ptr PgfExn -> IO () +#endif + foreign import ccall "pgf_free_revision" pgf_free_revision_ :: Ptr PgfDB -> Ptr PGF -> IO () foreign import ccall "&pgf_free_revision" pgf_free_revision :: FinalizerEnvPtr PgfDB PGF