GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-22 17:42:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

use interleaved IO for peeking strings when possible

Browse Source
This commit is contained in:
Krasimir Angelov
2018-11-14 15:52:44 +01:00
parent 7239a45ac5
commit fd2aa96e65
5 changed files with 80 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

52
src/runtime/haskell-bind/PGF2.hsc
View File

@@ -140,13 +140,13 @@ readPGF fpath =
showPGF :: PGF -> String showPGF :: PGF -> String
showPGF p = showPGF p =
unsafePerformIO $ unsafePerformIO $ do
withGuPool $ \tmpPl -> tmpPl <- gu_new_pool
do (sb,out) <- newOut tmpPl (sb,out) <- newOut tmpPl
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
pgf_print (pgf p) out exn pgf_print (pgf p) out exn
touchPGF p touchPGF p
peekUtf8CStringBuf sb peekUtf8CStringBufResult sb tmpPl
-- | List of all languages available in the grammar. -- | List of all languages available in the grammar.
languages :: PGF -> Map.Map ConcName Concr languages :: PGF -> Map.Map ConcName Concr
@@ -410,37 +410,37 @@ graphvizDefaults = GraphvizOptions False False False True "" "" "" "" "" ""
-- | Renders an abstract syntax tree in a Graphviz format. -- | Renders an abstract syntax tree in a Graphviz format.
graphvizAbstractTree :: PGF -> GraphvizOptions -> Expr -> String graphvizAbstractTree :: PGF -> GraphvizOptions -> Expr -> String
graphvizAbstractTree p opts e = graphvizAbstractTree p opts e =
unsafePerformIO $ unsafePerformIO $ do
withGuPool $ \tmpPl -> tmpPl <- gu_new_pool
do (sb,out) <- newOut tmpPl (sb,out) <- newOut tmpPl
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
c_opts <- newGraphvizOptions tmpPl opts c_opts <- newGraphvizOptions tmpPl opts
pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn
touchExpr e touchExpr e
peekUtf8CStringBuf sb peekUtf8CStringBufResult sb tmpPl
graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String
graphvizParseTree c opts e = graphvizParseTree c opts e =
unsafePerformIO $ unsafePerformIO $ do
withGuPool $ \tmpPl -> tmpPl <- gu_new_pool
do (sb,out) <- newOut tmpPl (sb,out) <- newOut tmpPl
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
c_opts <- newGraphvizOptions tmpPl opts c_opts <- newGraphvizOptions tmpPl opts
pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn
touchExpr e touchExpr e
peekUtf8CStringBuf sb peekUtf8CStringBufResult sb tmpPl
graphvizWordAlignment :: [Concr] -> GraphvizOptions -> Expr -> String graphvizWordAlignment :: [Concr] -> GraphvizOptions -> Expr -> String
graphvizWordAlignment cs opts e = graphvizWordAlignment cs opts e =
unsafePerformIO $ unsafePerformIO $
withGuPool $ \tmpPl ->
withArrayLen (map concr cs) $ \n_concrs ptr -> withArrayLen (map concr cs) $ \n_concrs ptr ->
do (sb,out) <- newOut tmpPl do tmpPl <- gu_new_pool
(sb,out) <- newOut tmpPl
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
c_opts <- newGraphvizOptions tmpPl opts c_opts <- newGraphvizOptions tmpPl opts
pgf_graphviz_word_alignment ptr (fromIntegral n_concrs) (expr e) c_opts out exn pgf_graphviz_word_alignment ptr (fromIntegral n_concrs) (expr e) c_opts out exn
touchExpr e touchExpr e
peekUtf8CStringBuf sb peekUtf8CStringBufResult sb tmpPl
newGraphvizOptions :: Ptr GuPool -> GraphvizOptions -> IO (Ptr PgfGraphvizOptions) newGraphvizOptions :: Ptr GuPool -> GraphvizOptions -> IO (Ptr PgfGraphvizOptions)
newGraphvizOptions pool opts = do newGraphvizOptions pool opts = do

16
src/runtime/haskell-bind/PGF2/Expr.hsc
View File

@@ -252,14 +252,14 @@ foreign import ccall "wrapper"
-- of binding. -- of binding.
showExpr :: [CId] -> Expr -> String showExpr :: [CId] -> Expr -> String
showExpr scope e = showExpr scope e =
unsafePerformIO $ unsafePerformIO $ do
withGuPool $ \tmpPl -> tmpPl <- gu_new_pool
do (sb,out) <- newOut tmpPl (sb,out) <- newOut tmpPl
printCtxt <- newPrintCtxt scope tmpPl printCtxt <- newPrintCtxt scope tmpPl
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
pgf_print_expr (expr e) printCtxt 1 out exn pgf_print_expr (expr e) printCtxt 1 out exn
touchExpr e touchExpr e
peekUtf8CStringBuf sb peekUtf8CStringBufResult sb tmpPl
newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext) newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext)
newPrintCtxt [] pool = return nullPtr newPrintCtxt [] pool = return nullPtr

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

@@ -15,6 +15,7 @@ import Control.Exception
import GHC.Ptr import GHC.Ptr
import Data.Int import Data.Int
import Data.Word import Data.Word
import System.IO.Unsafe
type Touch = IO () type Touch = IO ()
@@ -198,6 +199,23 @@ peekUtf8CStringBuf sbuf = do
len <- gu_string_buf_length sbuf len <- gu_string_buf_length sbuf
peekUtf8CStringLen ptr (fromIntegral len) peekUtf8CStringLen ptr (fromIntegral len)
peekUtf8CStringBufResult :: Ptr GuStringBuf -> Ptr GuPool -> IO String
peekUtf8CStringBufResult sbuf pool = do
fptr <- newForeignPtr gu_pool_finalizer pool
ptr <- gu_string_buf_data sbuf
len <- gu_string_buf_length sbuf
pptr <- gu_malloc pool (#size GuString*)
poke pptr ptr >> decode fptr pptr (ptr `plusPtr` fromIntegral len)
where
decode fptr pptr end = do
ptr <- peek pptr
if ptr >= end
then return []
else do x <- gu_utf8_decode pptr
cs <- unsafeInterleaveIO (decode fptr pptr end)
touchForeignPtr fptr
return (((toEnum . fromEnum) x) : cs)
pokeUtf8CString :: String -> CString -> IO () pokeUtf8CString :: String -> CString -> IO ()
pokeUtf8CString s ptr = pokeUtf8CString s ptr =
alloca $ \pptr -> alloca $ \pptr ->

34
src/runtime/haskell-bind/PGF2/Type.hsc
View File

@@ -45,14 +45,14 @@ readType str =
-- of binding. -- of binding.
showType :: [CId] -> Type -> String showType :: [CId] -> Type -> String
showType scope (Type ty touch) = showType scope (Type ty touch) =
unsafePerformIO $ unsafePerformIO $ do
withGuPool $ \tmpPl -> tmpPl <- gu_new_pool
do (sb,out) <- newOut tmpPl (sb,out) <- newOut tmpPl
printCtxt <- newPrintCtxt scope tmpPl printCtxt <- newPrintCtxt scope tmpPl
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
pgf_print_type ty printCtxt 0 out exn pgf_print_type ty printCtxt 0 out exn
touch touch
peekUtf8CStringBuf sb peekUtf8CStringBufResult sb tmpPl
-- | creates a type from a list of hypothesises, a category and -- | creates a type from a list of hypothesises, a category and
-- a list of arguments for the category. The operation -- a list of arguments for the category. The operation
@@ -128,12 +128,12 @@ unType (Type c_type touch) = unsafePerformIO $ do
-- of binding. -- of binding.
showContext :: [CId] -> [Hypo] -> String showContext :: [CId] -> [Hypo] -> String
showContext scope hypos = showContext scope hypos =
unsafePerformIO $ unsafePerformIO $ do
withGuPool $ \tmpPl -> tmpPl <- gu_new_pool
do (sb,out) <- newOut tmpPl (sb,out) <- newOut tmpPl
c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl
printCtxt <- newPrintCtxt scope tmpPl printCtxt <- newPrintCtxt scope tmpPl
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
pgf_print_context c_hypos printCtxt out exn pgf_print_context c_hypos printCtxt out exn
mapM_ touchHypo hypos mapM_ touchHypo hypos
peekUtf8CStringBuf sb peekUtf8CStringBufResult sb tmpPl

22
src/runtime/haskell-bind/SG.hsc
View File

@@ -196,17 +196,17 @@ readTriple str =
showTriple :: Expr -> Expr -> Expr -> String showTriple :: Expr -> Expr -> Expr -> String
showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) = showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
unsafePerformIO $ unsafePerformIO $
withGuPool $ \tmpPl -> withTriple $ \triple -> do
withTriple $ \triple -> do tmpPl <- gu_new_pool
(sb,out) <- newOut tmpPl (sb,out) <- newOut tmpPl
let printCtxt = nullPtr let printCtxt = nullPtr
exn <- gu_new_exn tmpPl exn <- gu_new_exn tmpPl
pokeElemOff triple 0 expr1 pokeElemOff triple 0 expr1
pokeElemOff triple 1 expr2 pokeElemOff triple 1 expr2
pokeElemOff triple 2 expr3 pokeElemOff triple 2 expr3
pgf_print_expr_tuple 3 triple printCtxt out exn pgf_print_expr_tuple 3 triple printCtxt out exn
touch1 >> touch2 >> touch3 touch1 >> touch2 >> touch3
peekUtf8CStringBuf sb peekUtf8CStringBufResult sb tmpPl
insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId
insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) = insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =