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

make linearizeAll in the Haskell binding lazy

Browse Source
This commit is contained in:
krasimir
2015-04-27 16:28:45 +00:00
parent 8efff76703
commit fc4b39d65f
1 changed files with 15 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -458,19 +458,20 @@ linearize lang e = unsafePerformIO $
linearizeAll :: Concr -> Expr -> [String] linearizeAll :: Concr -> Expr -> [String]
linearizeAll lang e = unsafePerformIO $ linearizeAll lang e = unsafePerformIO $
withGuPool $ \pl -> do pl <- gu_new_pool
do exn <- gu_new_exn pl exn <- gu_new_exn pl
cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl
failed <- gu_exn_is_raised exn failed <- gu_exn_is_raised exn
if failed if failed
then throwExn exn then throwExn exn pl
else collect cts exn pl else collect cts exn pl
where where
collect cts exn pl = do collect cts exn pl = do
ctree <- alloca $ \ptr -> do gu_enum_next cts ptr pl ctree <- alloca $ \ptr -> do gu_enum_next cts ptr pl
peek ptr peek ptr
if ctree == nullPtr if ctree == nullPtr
then return [] then do gu_pool_free pl
return []
else do (sb,out) <- newOut pl else do (sb,out) <- newOut pl
ctree <- pgf_lzr_wrap_linref ctree pl ctree <- pgf_lzr_wrap_linref ctree pl
pgf_lzr_linearize_simple (concr lang) ctree 0 out exn pl pgf_lzr_linearize_simple (concr lang) ctree 0 out exn pl
@@ -479,19 +480,21 @@ linearizeAll lang e = unsafePerformIO $
then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist
if is_nonexist if is_nonexist
then collect cts exn pl then collect cts exn pl
else throwExn exn else throwExn exn pl
else do lin <- gu_string_buf_freeze sb pl else do lin <- gu_string_buf_freeze sb pl
s <- peekCString lin s <- peekCString lin
ss <- collect cts exn pl ss <- unsafeInterleaveIO (collect cts exn pl)
return (s:ss) return (s:ss)
throwExn exn = do throwExn exn pl = do
is_exn <- gu_exn_caught exn gu_exn_type_PgfExn is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
if is_exn if is_exn
then do c_msg <- (#peek GuExn, data.data) exn then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekCString c_msg msg <- peekCString c_msg
gu_pool_free pl
throwIO (PGFError msg) throwIO (PGFError msg)
else throwIO (PGFError "The abstract tree cannot be linearized") else do gu_pool_free pl
throwIO (PGFError "The abstract tree cannot be linearized")
alignWords :: Concr -> Expr -> [(String, [Int])] alignWords :: Concr -> Expr -> [(String, [Int])]
alignWords lang e = unsafePerformIO $ alignWords lang e = unsafePerformIO $