3 files changed, 33 insertions, 37 deletions

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 629e020ce..8fb4e9387 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -26,6 +26,7 @@ module PGF2 (-- * PGF
 
 import Prelude hiding (fromEnum)
 import Control.Exception(Exception,throwIO)
+import Control.Monad(forM_)
 import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO)
 import PGF2.FFI
 
@@ -231,14 +232,18 @@ getAnalysis ref self c_lemma c_anal prob exn = do
   writeIORef ref ((lemma, anal, prob):ans)
 
 parse :: Concr -> String -> String -> Either String [(Expr,Float)]
-parse lang cat sent =
+parse lang cat sent = parse_with_heuristics lang cat sent (-1.0) []
+
+parse_with_heuristics :: Concr -> String -> String -> Double -> [(String, Int -> String -> Int -> Maybe (Expr,Float,Int))] -> Either String [(Expr,Float)]
+parse_with_heuristics lang cat sent heuristic callbacks =
   unsafePerformIO $
     do parsePl <- gu_new_pool
        exprPl  <- gu_new_pool
        exn     <- gu_new_exn parsePl
        enum    <- withCString cat $ \cat ->
-                    withCString sent $ \sent ->
-                      pgf_parse (concr lang) cat sent exn parsePl exprPl
+                    withCString sent $ \sent -> do
+                      callbacks_map <- mkCallbacksMap (concr lang) callbacks parsePl
+                      pgf_parse_with_heuristics (concr lang) cat sent heuristic callbacks_map exn parsePl exprPl
        failed  <- gu_exn_is_raised exn
        if failed
          then do is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError
@@ -263,28 +268,17 @@ 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
-    callback <- hspgf_new_literal_callback (concr lang)
-    match    <- wrapLiteralMatchCallback match_callback
-    predict  <- wrapLiteralPredictCallback predict_callback
-    (#poke PgfLiteralCallback, match)   callback match
-    (#poke PgfLiteralCallback, predict) callback predict
-    exn      <- gu_new_exn tmp_pool
-    pgf_concr_add_literal (concr lang) ccat callback exn
-    failed <- gu_exn_is_raised exn
-    if failed
-      then do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
-              if is_exn
-                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 return ()
+mkCallbacksMap :: Ptr PgfConcr -> [(String, Int -> String -> Int -> Maybe (Expr,Float,Int))] -> Ptr GuPool -> IO (Ptr PgfCallbacksMap)
+mkCallbacksMap concr callbacks pool = do
+  callbacks_map <- pgf_new_callbacks_map concr pool
+  forM_ callbacks $ \(cat,match) ->
+    withCString cat $ \ccat -> do
+      match    <- wrapLiteralMatchCallback (match_callback match)
+      predict  <- wrapLiteralPredictCallback predict_callback
+      hspgf_callbacks_map_add_literal concr callbacks_map ccat match predict pool
+  return callbacks_map
   where
-    match_callback _ clin_idx csentence poffset out_pool = do
+    match_callback match _ clin_idx csentence poffset out_pool = do
       sentence <- peekCString csentence
       coffset  <- peek poffset
       offset <- alloca $ \pcsentence -> do
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs
index 96c5b19fa..863431bca 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -91,7 +91,7 @@ data PgfFullFormEntry
 data PgfMorphoCallback
 data PgfPrintContext
 data PgfType
-data PgfLiteralCallback
+data PgfCallbacksMap
 
 foreign import ccall "pgf/pgf.h pgf_read"
   pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
@@ -138,8 +138,8 @@ foreign import ccall "pgf/pgf.h pgf_print_name"
 foreign import ccall "pgf/pgf.h pgf_linearize"
   pgf_linearize :: Ptr PgfConcr -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO ()
 
-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_parse_with_heuristics"
+  pgf_parse_with_heuristics :: Ptr PgfConcr -> CString -> CString -> Double -> Ptr PgfCallbacksMap -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
 
 type LiteralMatchCallback = Ptr () -> CInt -> CString -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb)
 
@@ -151,11 +151,11 @@ type LiteralPredictCallback = Ptr () -> CInt -> CString -> Ptr GuPool -> IO (Ptr
 foreign import ccall "wrapper"
   wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback)
 
-foreign import ccall 
-  hspgf_new_literal_callback :: Ptr PgfConcr -> IO (Ptr PgfLiteralCallback)
+foreign import ccall "pgf/pgf.h pgf_new_callbacks_map"
+  pgf_new_callbacks_map :: Ptr PgfConcr -> Ptr GuPool -> IO (Ptr PgfCallbacksMap)
 
-foreign import ccall "pgf/pgf.h pgf_concr_add_literal"
-  pgf_concr_add_literal :: Ptr PgfConcr -> CString -> Ptr PgfLiteralCallback -> Ptr GuExn -> IO ()
+foreign import ccall
+  hspgf_callbacks_map_add_literal :: Ptr PgfConcr -> Ptr PgfCallbacksMap -> CString -> FunPtr LiteralMatchCallback -> FunPtr LiteralPredictCallback -> Ptr GuPool -> IO ()
 
 foreign import ccall "pgf/pgf.h pgf_lookup_morpho"
   pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
diff --git a/src/runtime/haskell-bind/utils.c b/src/runtime/haskell-bind/utils.c
index 8ab1e53e3..8bdb99038 100644
--- a/src/runtime/haskell-bind/utils.c
+++ b/src/runtime/haskell-bind/utils.c
@@ -17,13 +17,15 @@ hspgf_literal_callback_fin(GuFinalizer* self)
 		hs_free_fun_ptr((HsFunPtr) callback->callback.predict);
 }
 
-PgfLiteralCallback*
-hspgf_new_literal_callback(PgfConcr* concr) {
-	GuPool* pool = pgf_concr_get_pool(concr);
+void
+hspgf_callbacks_map_add_literal(PgfConcr* concr, PgfCallbacksMap* callbacks,
+                                PgfCId cat, HsFunPtr match, HsFunPtr predict,
+                                GuPool* pool)
+{
 	HSPgfLiteralCallback* callback = gu_new(HSPgfLiteralCallback, pool);
-	callback->callback.match   = NULL;
-	callback->callback.predict = NULL;
+	callback->callback.match   = (void*) match;
+	callback->callback.predict = (void*) predict;
 	callback->fin.fn = hspgf_literal_callback_fin;
 	gu_pool_finally(pool, &callback->fin);
-	return &callback->callback;
+	pgf_callbacks_map_add_literal(concr, callbacks, cat, &callback->callback);
 }