change in the API for literals

The API in the C runtime as well as in the Haskell, Python and Java binding
is changed. Now instead of adding the literal callbacks to the concrete syntax
you need to supply them every time when you need to parse. The main reason is:

- referentially transparent API for Haskell
- when we start using memory mapped files we will not be allowed to change
  anything in the grammar data structures. At that point the old API would
  be impossible to use.

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);
 }