added an API for custom literals in the Haskell binding

2 files changed, 78 insertions, 1 deletions

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 ()