the Literals API in Haskell no longer offers the sentence as an argument to the callbacks. It is just as easy to save the sentence in a closure and by doing that we save the repeated round about from C to Haskell strings

5 files changed, 14 insertions, 17 deletions

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index af310b17f..6435813ee 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -267,7 +267,7 @@ parseWithHeuristics :: Concr      -- ^ the language with which we parse
                                   -- A negative value tells the parser 
                                   -- to lookup up the default from 
                                   -- the grammar flags
-                    -> [(Cat, Int -> String -> Int -> Maybe (Expr,Float,Int))]
+                    -> [(Cat, Int -> Int -> Maybe (Expr,Float,Int))]
                                   -- ^ a list of callbacks for literal categories.
                                   -- The arguments of the callback are:
                                   -- the index of the constituent for the literal category;
@@ -308,7 +308,7 @@ parseWithHeuristics lang cat sent heuristic callbacks =
                  exprs    <- fromPgfExprEnum enum parseFPl (lang,exprFPl)
                  return (Right exprs)
 
-mkCallbacksMap :: Ptr PgfConcr -> [(String, Int -> String -> Int -> Maybe (Expr,Float,Int))] -> Ptr GuPool -> IO (Ptr PgfCallbacksMap)
+mkCallbacksMap :: Ptr PgfConcr -> [(String, Int -> 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) -> do
@@ -318,10 +318,9 @@ mkCallbacksMap concr callbacks pool = do
     hspgf_callbacks_map_add_literal concr callbacks_map ccat match predict pool
   return callbacks_map
   where
-    match_callback match _ clin_idx csentence poffset out_pool = do
-      sentence <- peekUtf8CString csentence
+    match_callback match clin_idx poffset out_pool = do
       coffset <- peek poffset
-      case match (fromIntegral clin_idx) sentence (fromIntegral coffset) of
+      case match (fromIntegral clin_idx) (fromIntegral coffset) of
         Nothing               -> return nullPtr
         Just (e,prob,offset') -> do poke poffset (fromIntegral offset')
 
@@ -342,7 +341,7 @@ mkCallbacksMap concr callbacks pool = do
                                     (#poke PgfExprProb, prob) ep prob
                                     return ep
 
-    predict_callback _ _ _ _ = return nullPtr
+    predict_callback _ _ _ = return nullPtr
 
 -- | The oracle is a triple of functions.
 -- The first two take a category name and a linearization field name
@@ -574,7 +573,7 @@ instance Exception PGFError
 -----------------------------------------------------------------------
 
 type LiteralCallback =
-       PGF -> (ConcName,Concr) -> Int -> String -> Int -> Maybe (Expr,Float,Int)
+       PGF -> (ConcName,Concr) -> String -> Int -> Int -> Maybe (Expr,Float,Int)
 
 -- | Callbacks for the App grammar
 literalCallbacks :: [(AbsName,[(Cat,LiteralCallback)])]
@@ -583,7 +582,7 @@ literalCallbacks = [("App",[("PN",nerc),("Symb",chunk)])]
 -- | Named entity recognition for the App grammar 
 -- (based on ../java/org/grammaticalframework/pgf/NercLiteralCallback.java)
 nerc :: LiteralCallback
-nerc pgf (lang,concr) lin_idx sentence offset =
+nerc pgf (lang,concr) sentence lin_idx offset =
   case consume capitalized (drop offset sentence) of
     (capwords@(_:_),rest) |
        not ("Eng" `isSuffixOf` lang && name `elem` ["I","I'm"]) ->
@@ -618,7 +617,7 @@ nerc pgf (lang,concr) lin_idx sentence offset =
 -- | Callback to parse arbitrary words as chunks (from
 -- ../java/org/grammaticalframework/pgf/UnknownLiteralCallback.java)
 chunk :: LiteralCallback
-chunk _ (_,concr) lin_idx sentence offset =
+chunk _ (_,concr) sentence lin_idx offset =
   case uncapitalized (drop offset sentence) of
     Just (word0@(_:_),rest) | null (lookupMorpho concr word) ->
         Just (expr,0,offset+length word)
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs
index 1e3abec64..bc9622a68 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -199,12 +199,12 @@ foreign import ccall "pgf/pgf.h pgf_align_words"
 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)
+type LiteralMatchCallback = CInt -> 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)
+type LiteralPredictCallback = CInt -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb)
 
 foreign import ccall "wrapper"
   wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback)
diff --git a/src/runtime/haskell-bind/examples/pgf-hsbind-trans.hs b/src/runtime/haskell-bind/examples/pgf-hsbind-trans.hs
index 7487c04df..96808f906 100644
--- a/src/runtime/haskell-bind/examples/pgf-hsbind-trans.hs
+++ b/src/runtime/haskell-bind/examples/pgf-hsbind-trans.hs
@@ -50,7 +50,7 @@ translates pgf cfrom cto cat (mxt,mxv) s0 =
 
 cparse pgf concr cat input = parseWithHeuristics concr cat input (-1) callbacks where
   callbacks = maybe [] cb $ lookup "App" literalCallbacks
-  cb fs = [(cat,f pgf ("TranslateEng",concr))|(cat,f)<-fs]
+  cb fs = [(cat,f pgf ("TranslateEng",concr) input)|(cat,f)<-fs]
 
 lextext cnc = unwords . lexText' (\w -> case lookupMorpho cnc w of
   _:_ -> w
diff --git a/src/runtime/haskell-bind/utils.c b/src/runtime/haskell-bind/utils.c
index ee1c32ea1..5afb33b5c 100644
--- a/src/runtime/haskell-bind/utils.c
+++ b/src/runtime/haskell-bind/utils.c
@@ -4,9 +4,7 @@
 
 typedef struct {
 	PgfLiteralCallback callback;
-	PgfExprProb* (*match)(PgfLiteralCallback* self,
-	                      size_t lin_idx,
-	                      GuString sentence, size_t* poffset,
+	PgfExprProb* (*match)(size_t lin_idx, size_t* poffset,
 	                      GuPool *out_pool);
 	GuFinalizer fin;
 } HSPgfLiteralCallback;
@@ -48,7 +46,7 @@ hspgf_match_callback(PgfLiteralCallback* self, PgfConcr* concr,
 	size_t hs_offset =
 		hspgf_offset2hs(sentence, *poffset);
 	PgfExprProb* ep =
-		callback->match(self, lin_idx, sentence, &hs_offset, out_pool);
+		callback->match(lin_idx, &hs_offset, out_pool);
 	*poffset = hspgf_hs2offset(sentence, hs_offset);
 
 	return ep;
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index 08090f309..2d0154e4c 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -173,7 +173,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
       --cparse = C.parse concr cat input
         cparse = C.parseWithHeuristics concr cat input (-1) callbacks
         callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks
-        cb fs = [(cat,f pgf (from,concr))|(cat,f)<-fs]
+        cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs]
 {-
     -- Caching parse results:
     parse' start mlimit ((from,concr),input) =