diff options
Diffstat (limited to 'src/runtime/haskell-bind')
| -rw-r--r-- | src/runtime/haskell-bind/CRuntimeFFI.hsc | 84 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PgfLow.hs | 4 |
2 files changed, 38 insertions, 50 deletions
diff --git a/src/runtime/haskell-bind/CRuntimeFFI.hsc b/src/runtime/haskell-bind/CRuntimeFFI.hsc index 24329c319..6564ac70e 100644 --- a/src/runtime/haskell-bind/CRuntimeFFI.hsc +++ b/src/runtime/haskell-bind/CRuntimeFFI.hsc @@ -6,14 +6,12 @@ module CRuntimeFFI(-- * PGF PGF,readPGF,abstractName,startCat, -- * Concrete syntax - Concr,Language,{-languages,-}getConcr,parse,linearize, + Concr,Language,languages,getConcr,parse,linearize, -- * Trees Expr,Tree,readExpr,showExpr,unApp, -- * Morphology MorphoAnalysis,lookupMorpho,fullFormLexicon, printLexEntry, - -- * Don't export these for real, just for testing - generateAll, printGrammar ) where import Prelude hiding (fromEnum) @@ -33,6 +31,7 @@ import Foreign.Ptr import Data.Char +import Data.Map (Map, empty, insert) import qualified Data.ByteString as BS import Data.IORef @@ -49,12 +48,6 @@ import Data.IORef type Pool = ForeignPtr GuPool type Out = (Ptr GuStringBuf, Ptr GuOut) - ---Not used anymore, see withGuPool in Gu.hsc -newPool :: IO Pool -newPool = - do pl <- gu_new_pool - newForeignPtr_ pl --gu_pool_free_ptr pl --when you create a GuOut, you create also a GuStringBuf --and when you give GuOut to a function that outputs something, @@ -101,14 +94,23 @@ getConcr p (CId lang) = unsafePerformIO $ return (if cnc==nullPtr then Nothing else Just (Concr cnc p)) +languages :: PGF -> Map Language Concr +languages p = unsafePerformIO $ + do ref <- newIORef empty + allocaBytes (#size GuMapItor) $ \itor -> + do fptr <- wrapLanguages (getLanguages ref) + (#poke GuMapItor, fn) itor fptr + pgf_iter_languages (pgf p) itor nullPtr + readIORef ref + where + getLanguages :: IORef (Map Language Concr) -> Languages + getLanguages ref itor key value exn = do + langs <- readIORef ref + key' <- fmap CId $ BS.packCString (castPtr key) + value' <- fmap (\ptr -> Concr ptr p) $ peek (castPtr value) + writeIORef ref (insert key' value' langs) +--type Languages = Ptr GuMapItor -> Ptr () -> Ptr () -> Ptr GuExn -> IO ( --- languages :: PGF -> [Concr] --- languages p = undefined ---TODO --- void pgf_iter_languages(PgfPGF* pgf, GuMapItor* fn, GuExn* err) --- { --- gu_map_iter(pgf->concretes, fn, err); --- } generateAll :: PGF -> CId -> [(Tree,Float)] generateAll p (CId cat) = unsafePerformIO $ @@ -195,15 +197,13 @@ readExpr str = unsafePerformIO $ -- TODO: do we need 3 different pools for this? showExpr :: Expr -> String showExpr e = unsafePerformIO $ - withGuPool $ \outPl -> - withGuPool $ \exnPl -> - withGuPool $ \printPl -> - do (sb,out) <- newOut outPl - let printCtxt = nullPtr - exn <- gu_new_exn nullPtr gu_type__type exnPl - pgf_print_expr (expr e) printCtxt 1 out exn - abstree <- gu_string_buf_freeze sb printPl - peekCString abstree + withGuPool $ \pl -> + do (sb,out) <- newOut pl + let printCtxt = nullPtr + exn <- gu_new_exn nullPtr gu_type__type pl + pgf_print_expr (expr e) printCtxt 1 out exn + abstree <- gu_string_buf_freeze sb pl + peekCString abstree ----------------------------------------------------------------------------- @@ -239,11 +239,9 @@ fullFormLexicon lang = in zip lexicon analyses where fullformLexicon' :: Concr -> [String] fullformLexicon' lang = unsafePerformIO $ - withGuPool $ \iterPl -> do pl <- gu_new_pool lexEnum <- pgf_fullform_lexicon (concr lang) pl - fromFullFormEntry lexEnum pl (concrMaster lang) ---Something weird happens if I use iterPl ^- here + fromFullFormEntry lexEnum pl (concrMaster lang) printLexEntry :: (String, [MorphoAnalysis]) -> String printLexEntry (lemma, anals) = @@ -257,12 +255,12 @@ printLexEntry (lemma, anals) = parse :: Concr -> CId -> String -> [(Tree,Float)] parse (Concr lang master) (CId cat) sent = unsafePerformIO $ withGuPool $ \iterPl -> -- this pool will get freed eventually - do inpool <- gu_new_pool --these pools not ??? - outpool <- gu_new_pool --if I add them into withGuPool, I get segfault - treesEnum <- parse_ lang cat sent inpool outpool - fromPgfExprEnum treesEnum iterPl master --see previous fromPgfExprEnum comment, why giving a pool as an argument here instead of creating them in fromPgfExprEnum + do inpool <- gu_new_pool + outpool <- gu_new_pool + treesEnum <- parse_ lang cat sent inpool outpool + outpoolFPtr <- newForeignPtr gu_pool_free_ptr outpool + fromPgfExprEnum treesEnum iterPl (master,outpoolFPtr) where - --tried adding withGuPool stuff inside here, segfaults as well parse_ :: Ptr PgfConcr -> BS.ByteString -> String -> Ptr GuPool -> Ptr GuPool -> IO (Ptr PgfExprEnum) parse_ pgfcnc cat sent inpool outpool = do BS.useAsCString cat $ \cat -> @@ -289,9 +287,8 @@ linearize lang tree = unsafePerformIO $ fromPgfExprEnum :: Ptr PgfExprEnum -> Ptr GuPool -> a -> IO [(Tree, Float)] fromPgfExprEnum enum pl master = do pgfExprProb <- alloca $ \ptr -> --- withGuPool $ \pl -> - do gu_enum_next enum ptr pl - peek ptr + do gu_enum_next enum ptr pl + peek ptr if pgfExprProb == nullPtr then return [] else do expr <- (#peek PgfExprProb, expr) pgfExprProb @@ -299,7 +296,7 @@ fromPgfExprEnum enum pl master = ts <- unsafeInterleaveIO (fromPgfExprEnum enum pl master) return ((Expr expr master,prob) : ts) ---TODO + fromFullFormEntry :: Ptr GuEnum -> Ptr GuPool -> PGF -> IO [String] fromFullFormEntry enum pl master = do ffEntry <- alloca $ \ptr -> @@ -311,16 +308,3 @@ fromFullFormEntry enum pl master = else do tok <- peekCString =<< pgf_fullform_get_string ffEntry toks <- unsafeInterleaveIO (fromFullFormEntry enum pl master) return (tok : toks) - --- fromFullFormEntry :: Ptr GuEnum -> PGF -> IO [String] --- fromFullFormEntry enum master = --- do ffEntry <- alloca $ \ptr -> --- withGuPool $ \pl -> --- do gu_enum_next enum ptr pl --- peek ptr --- -- ffEntry :: Ptr PgfFullFormEntry --- if ffEntry == nullPtr --- then return [] --- else do tok <- peekCString =<< pgf_fullform_get_string ffEntry --- toks <- unsafeInterleaveIO (fromFullFormEntry enum master) --- return (tok : toks)
\ No newline at end of file diff --git a/src/runtime/haskell-bind/PgfLow.hs b/src/runtime/haskell-bind/PgfLow.hs index 1eb45b54e..0caad1ab9 100644 --- a/src/runtime/haskell-bind/PgfLow.hs +++ b/src/runtime/haskell-bind/PgfLow.hs @@ -92,6 +92,10 @@ type Callback = Ptr PgfMorphoCallback -> CString -> CString -> Float -> Ptr GuEx foreign import ccall "wrapper" wrapLookupMorpho :: Callback -> IO (FunPtr Callback) +type Languages = Ptr GuMapItor -> Ptr () -> Ptr () -> Ptr GuExn -> IO () + +foreign import ccall "wrapper" + wrapLanguages :: Languages -> IO (FunPtr Languages) --GuEnum* pgf_fullform_lexicon(PgfConcr *concr, GuPool* pool); foreign import ccall "pgf/pgf.h pgf_fullform_lexicon" |