diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 35631cd4c..7910ece81 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -16,7 +16,7 @@ module PGF2 (-- * PGF PGF,readPGF,abstractName,startCat, loadConcr,unloadConcr, -- * Concrete syntax - Concr,languages,parse,linearize, + Concr,languages,parse,linearize,addLiteral, -- * Trees Expr,readExpr,showExpr,unApp, -- * Morphology @@ -263,6 +263,64 @@ parse lang cat sent = exprs <- fromPgfExprEnum enum parseFPl (lang,exprFPl) return (Right exprs) +addLiteral :: Concr -> String -> (Int -> String -> Int -> Maybe (Expr,Float,Int)) -> IO () +addLiteral lang cat match = + withCString cat $ \ccat -> + withGuPool $ \tmp_pool -> do + pool <- pgf_concr_get_pool (concr lang) + callback <- gu_malloc pool (#size PgfLiteralCallback) + match <- wrapLiteralMatchCallback match_callback + predict <- wrapLiteralPredictCallback predict_callback + (#poke PgfLiteralCallback, match) callback match + (#poke PgfLiteralCallback, predict) callback predict + exn <- gu_new_exn nullPtr gu_type__type tmp_pool + pgf_concr_add_literal (concr lang) ccat callback exn + failed <- gu_exn_is_raised exn + if failed + then do ty <- gu_exn_caught exn + if ty == gu_type__PgfExn + then do c_msg <- (#peek GuExn, data.data) exn + msg <- peekCString c_msg + throwIO (PGFError msg) + else throwIO (PGFError "The literal cannot be added") + else do return () + where + match_callback _ clin_idx csentence poffset out_pool = do + sentence <- peekCString csentence + coffset <- peek poffset + offset <- alloca $ \pcsentence -> do + poke pcsentence csentence + gu2hs_string_offset pcsentence (plusPtr csentence (fromIntegral coffset)) 0 + case match (fromIntegral clin_idx) sentence offset of + Nothing -> return nullPtr + Just (e,prob,offset') -> do poke poffset (fromIntegral offset') + + -- here we copy the expression to out_pool + c_e <- withGuPool $ \tmpPl -> do + exn <- gu_new_exn nullPtr gu_type__type tmpPl + + (sb,out) <- newOut tmpPl + let printCtxt = nullPtr + pgf_print_expr (expr e) printCtxt 1 out exn + c_str <- gu_string_buf_freeze sb tmpPl + + guin <- gu_string_in c_str tmpPl + pgf_read_expr guin out_pool exn + + ep <- gu_malloc out_pool (#size PgfExprProb) + (#poke PgfExprProb, expr) ep c_e + (#poke PgfExprProb, prob) ep prob + return ep + + predict_callback _ _ _ _ = return nullPtr + + gu2hs_string_offset pcstart cend offset = do + cstart <- peek pcstart + if cstart < cend + then do gu_utf8_decode pcstart + gu2hs_string_offset pcstart cend (offset+1) + else return offset + linearize :: Concr -> Expr -> String linearize lang e = unsafePerformIO $ withGuPool $ \pl -> diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index b686a8ee9..9b0f9961e 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -78,6 +78,9 @@ foreign import ccall "gu/enum.h gu_enum_next" foreign import ccall "gu/string.h gu_string_buf_freeze" gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString +foreign import ccall "gu/utf8.h gu_utf8_decode" + gu_utf8_decode :: Ptr (Ptr CChar) -> IO () + withGuPool :: (Ptr GuPool -> IO a) -> IO a withGuPool f = bracket gu_new_pool gu_pool_free f @@ -143,6 +146,22 @@ foreign import ccall "pgf/pgf.h pgf_linearize" foreign import ccall "pgf/pgf.h pgf_parse" pgf_parse :: Ptr PgfConcr -> CString -> CString -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum) +foreign import ccall "pgf/pgf.h pgf_concr_get_pool" + pgf_concr_get_pool :: Ptr PgfConcr -> IO (Ptr GuPool) + +type LiteralMatchCallback = Ptr () -> CInt -> CString -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb) + +foreign import ccall "wrapper" + wrapLiteralMatchCallback :: LiteralMatchCallback -> IO (FunPtr LiteralMatchCallback) + +type LiteralPredictCallback = Ptr () -> CInt -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb) + +foreign import ccall "wrapper" + wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback) + +foreign import ccall "pgf/pgf.h pgf_concr_add_literal" + pgf_concr_add_literal :: Ptr PgfConcr -> CString -> Ptr () -> Ptr GuExn -> IO () + foreign import ccall "pgf/pgf.h pgf_lookup_morpho" pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()