From 84fd431afd54644bbe4bfc2c09c444f5a99e35cb Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Mon, 3 May 2021 22:28:48 +0200
Subject: [PATCH] Manage to get completion working in PGF2

---
 src/runtime/haskell-bind/PGF2.hsc     | 23 ++++++++++++-----------
 src/runtime/haskell-bind/PGF2/FFI.hsc |  1 +
 src/runtime/haskell-bind/test.hs      | 25 -------------------------
 3 files changed, 13 insertions(+), 36 deletions(-)
 delete mode 100644 src/runtime/haskell-bind/test.hs

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index b3b349ee1..38fae67ef 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -972,13 +972,13 @@ parseWithOracle lang cat sent (predict,complete,literal) =
                          return ep
         Nothing    -> do return nullPtr
 
+-- | Returns possible completions of the current partial input.
 complete :: Concr      -- ^ the language with which we parse
-         -> Type        -- ^ the start category
-         -> String     -- ^ the input sentence
-         -> String     -- ^ prefix (?)
-         -> Maybe Int  -- ^ maximum number of results
-         -> ParseOutput [String]
-complete lang (Type ctype _) sent pfx mn =
+         -> Type       -- ^ the start category
+         -> String     -- ^ the input sentence (excluding token being completed)
+         -> String     -- ^ prefix (partial token being completed)
+         -> ParseOutput [(String, CId, CId, Float)]  -- ^ (token, category, function, probability)
+complete lang (Type ctype _) sent pfx =
   unsafePerformIO $ do
     parsePl <- gu_new_pool
     exn     <- gu_new_exn parsePl
@@ -1013,7 +1013,7 @@ complete lang (Type ctype _) sent pfx mn =
       fpl <- newForeignPtr gu_pool_finalizer parsePl
       ParseOk <$> fromCompletions enum fpl
   where
-    fromCompletions :: Ptr GuEnum -> ForeignPtr GuPool -> IO [String]
+    fromCompletions :: Ptr GuEnum -> ForeignPtr GuPool -> IO [(String, CId, CId, Float)]
     fromCompletions enum fpl =
       withGuPool $ \tmpPl -> do
         cmpEntry <- alloca $ \ptr ->
@@ -1026,11 +1026,12 @@ complete lang (Type ctype _) sent pfx mn =
           touchConcr lang
           return []
         else do
-          (sb,out) <- newOut tmpPl
-          cstr <- gu_string_buf_freeze sb tmpPl
-          tok  <- peekUtf8CString cstr
+          tok <- peekUtf8CString =<< (#peek PgfTokenProb, tok) cmpEntry
+          cat <- peekUtf8CString =<< (#peek PgfTokenProb, cat) cmpEntry
+          fun <- peekUtf8CString =<< (#peek PgfTokenProb, fun) cmpEntry
+          prob <- (#peek PgfTokenProb, prob) cmpEntry
           toks <- unsafeInterleaveIO (fromCompletions enum fpl)
-          return (tok : toks)
+          return ((tok, cat, fun, prob) : toks)
 
 -- | Returns True if there is a linearization defined for that function in that language
 hasLinearization :: Concr -> Fun -> Bool
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc
index 04952f2d8..16f9ad46d 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hsc
+++ b/src/runtime/haskell-bind/PGF2/FFI.hsc
@@ -256,6 +256,7 @@ data PgfApplication
 data PgfConcr
 type PgfExpr = Ptr ()
 data PgfExprProb
+data PgfTokenProb
 data PgfExprParser
 data PgfFullFormEntry
 data PgfMorphoCallback
diff --git a/src/runtime/haskell-bind/test.hs b/src/runtime/haskell-bind/test.hs
deleted file mode 100644
index 1c0c9fa87..000000000
--- a/src/runtime/haskell-bind/test.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-import PGF2
-import qualified Data.Char as C
-import qualified Data.List as L
-import qualified Data.Map as M
-
-main :: IO ()
-main = do
-  pgf <- readPGF "/Users/john/repositories/GF/contrib/foods/Foods.pgf"
-  let
-    Just concr = M.lookup "FoodsEng" (languages pgf)
-    loop = do
-      putStr "> "
-      input <- getLine
-      let
-        (sent,pfx) =
-          if C.isSpace (last input)
-          then (input, "")
-          else let toks = words input in (unwords (init toks), last toks)
-      let pr = complete concr (startCat pgf) sent pfx Nothing
-      case pr of
-        ParseOk x -> print x
-        ParseFailed x s -> putStrLn $ "parse failed at " ++ show x ++ " " ++ s
-        ParseIncomplete -> putStrLn "input incomplete"
-      loop
-  loop