bugfix and tiny optimization for callbacks from Haskell

3 files changed, 43 insertions, 18 deletions

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index aa752d4b0..44f9d2b1c 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -318,11 +318,8 @@ mkCallbacksMap concr callbacks pool = do
   where
     match_callback match _ 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
+      coffset <- peek poffset
+      case match (fromIntegral clin_idx) sentence (fromIntegral coffset) of
         Nothing               -> return nullPtr
         Just (e,prob,offset') -> do poke poffset (fromIntegral offset')
 
@@ -345,13 +342,6 @@ mkCallbacksMap concr callbacks pool = do
 
     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 8ddc536b9..b96c93e17 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -72,9 +72,6 @@ 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
 
diff --git a/src/runtime/haskell-bind/utils.c b/src/runtime/haskell-bind/utils.c
index 8bdb99038..0724cde21 100644
--- a/src/runtime/haskell-bind/utils.c
+++ b/src/runtime/haskell-bind/utils.c
@@ -1,18 +1,55 @@
 #include <HsFFI.h>
 #include <pgf/pgf.h>
+#include <gu/utf8.h>
 
 typedef struct {
 	PgfLiteralCallback callback;
+	PgfExprProb* (*match)(PgfLiteralCallback* self,
+	                      size_t lin_idx,
+	                      GuString sentence, size_t* poffset,
+	                      GuPool *out_pool);
 	GuFinalizer fin;
 } HSPgfLiteralCallback;
 
-static void 
+static PgfExprProb*
+hspgf_match_callback(PgfLiteralCallback* self,
+	                 size_t lin_idx,
+	                 GuString sentence, size_t* poffset,
+	                 GuPool *out_pool)
+{
+	HSPgfLiteralCallback* callback = (HSPgfLiteralCallback*) self;
+	size_t offset = *poffset;
+
+	const uint8_t *start = sentence;
+	const uint8_t *end   = sentence + offset;
+	size_t hs_offset = 0;
+	while (start < end) {
+		gu_utf8_decode(&start);
+		hs_offset++;
+	}
+
+	PgfExprProb* ep =
+		callback->match(self, lin_idx, sentence, &hs_offset, out_pool);
+
+	start = sentence;
+	end   = start;
+	while (hs_offset > 0) {
+		gu_utf8_decode(&end);
+		hs_offset--;
+	}
+
+	*poffset = (end - start);
+
+	return ep;
+}
+
+static void
 hspgf_literal_callback_fin(GuFinalizer* self)
 {
 	HSPgfLiteralCallback* callback = gu_container(self, HSPgfLiteralCallback, fin);
 	
 	if (callback->callback.match != NULL)
-		hs_free_fun_ptr((HsFunPtr) callback->callback.match);
+		hs_free_fun_ptr((HsFunPtr) callback->match);
 	if (callback->callback.predict != NULL)
 		hs_free_fun_ptr((HsFunPtr) callback->callback.predict);
 }
@@ -23,8 +60,9 @@ hspgf_callbacks_map_add_literal(PgfConcr* concr, PgfCallbacksMap* callbacks,
                                 GuPool* pool)
 {
 	HSPgfLiteralCallback* callback = gu_new(HSPgfLiteralCallback, pool);
-	callback->callback.match   = (void*) match;
+	callback->callback.match   = hspgf_match_callback;
 	callback->callback.predict = (void*) predict;
+	callback->match  = (void*) match;
 	callback->fin.fn = hspgf_literal_callback_fin;
 	gu_pool_finally(pool, &callback->fin);
 	pgf_callbacks_map_add_literal(concr, callbacks, cat, &callback->callback);