an API for oracles in the GF parser

3 files changed, 130 insertions, 1 deletions

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index e88dcc9ce..80abc3775 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -17,7 +17,8 @@ module PGF2 (-- * CId
              -- * PGF
              PGF,readPGF,AbsName,abstractName,Cat,startCat,categories,
              -- * Concrete syntax
-             ConcName,Concr,languages,parse,parseWithHeuristics,
+             ConcName,Concr,languages,parse,
+             parseWithHeuristics, parseWithOracle,
              hasLinearization,linearize,linearizeAll,alignWords,
              -- * Types
              Type(..), Hypo, BindType(..), showType, functionType,
@@ -340,6 +341,88 @@ mkCallbacksMap concr callbacks pool = do
 
     predict_callback _ _ _ _ = return nullPtr
 
+-- | The oracle is a triple of functions.
+-- The first two take a category name and a linearization field name
+-- and they should return True/False when the corresponding 
+-- prediction or completion is appropriate. The third function
+-- is the oracle for literals.
+type Oracle = (Maybe (Cat -> String -> Int -> Bool)
+              ,Maybe (Cat -> String -> Int -> Bool)
+              ,Maybe (Cat -> String -> Int -> Maybe (Expr,Float,Int))
+              )
+
+parseWithOracle :: Concr      -- ^ the language with which we parse
+                -> Cat        -- ^ the start category
+                -> String     -- ^ the input sentence
+                -> Oracle
+                -> Either String [(Expr,Float)]
+parseWithOracle lang cat sent (predict,complete,literal) =
+  unsafePerformIO $
+    do parsePl <- gu_new_pool
+       exprPl  <- gu_new_pool
+       exn     <- gu_new_exn parsePl
+       enum    <- withCString cat $ \cat ->
+                    withCString sent $ \sent -> do
+                      predictPtr  <- maybe (return nullFunPtr) (wrapOracleCallback . oracleWrapper) predict
+                      completePtr <- maybe (return nullFunPtr) (wrapOracleCallback . oracleWrapper) complete
+                      literalPtr  <- maybe (return nullFunPtr) (wrapOracleLiteralCallback . oracleLiteralWrapper) literal
+                      cback <- hspgf_new_oracle_callback predictPtr completePtr literalPtr parsePl
+                      pgf_parse_with_oracle (concr lang) cat sent cback exn parsePl exprPl
+       failed  <- gu_exn_is_raised exn
+       if failed
+         then do is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError
+                 if is_parse_error
+                   then do c_tok <- (#peek GuExn, data.data) exn
+                           tok <- peekCString c_tok
+                           gu_pool_free parsePl
+                           gu_pool_free exprPl
+                           return (Left tok)
+                   else 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
+                                     gu_pool_free parsePl
+                                     gu_pool_free exprPl
+                                     throwIO (PGFError msg)
+                             else do gu_pool_free parsePl
+                                     gu_pool_free exprPl
+                                     throwIO (PGFError "Parsing failed")
+         else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl
+                 exprFPl  <- newForeignPtr gu_pool_finalizer exprPl
+                 exprs    <- fromPgfExprEnum enum parseFPl (lang,exprFPl)
+                 return (Right exprs)
+  where
+    oracleWrapper oracle _ catPtr lblPtr offset = do
+      cat <- peekCString catPtr
+      lbl <- peekCString lblPtr
+      return (oracle cat lbl (fromIntegral offset))
+
+    oracleLiteralWrapper oracle _ catPtr lblPtr poffset out_pool = do
+      cat <- peekCString catPtr
+      lbl <- peekCString lblPtr
+      offset <- peek poffset
+      case oracle cat lbl (fromIntegral offset) of
+        Just (e,prob,offset) ->
+                      do poke poffset (fromIntegral offset)
+
+                         -- here we copy the expression to out_pool
+                         c_e <- withGuPool $ \tmpPl -> do
+                                  exn <- gu_new_exn tmpPl
+
+                                  (sb,out) <- newOut tmpPl
+                                  let printCtxt = nullPtr
+                                  pgf_print_expr (expr e) printCtxt 1 out exn
+                                  c_str <- gu_string_buf_freeze sb tmpPl
+
+                                  guin <- gu_string_in c_str tmpPl
+                                  pgf_read_expr guin out_pool exn
+
+                         ep <- gu_malloc out_pool (#size PgfExprProb)
+                         (#poke PgfExprProb, expr) ep c_e
+                         (#poke PgfExprProb, prob) ep prob
+                         return ep
+        Nothing    -> do return nullPtr
+
 hasLinearization :: Concr -> Fun -> Bool
 hasLinearization lang id = unsafePerformIO $
   withCString id (pgf_has_linearization (concr lang))
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs
index fc658d83d..67830e890 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -98,6 +98,7 @@ data PgfMorphoCallback
 data PgfPrintContext
 data PgfType
 data PgfCallbacksMap
+data PgfOracleCallback
 data PgfCncTree
 
 foreign import ccall "pgf/pgf.h pgf_read"
@@ -179,6 +180,21 @@ foreign import ccall "pgf/pgf.h pgf_new_callbacks_map"
 foreign import ccall
   hspgf_callbacks_map_add_literal :: Ptr PgfConcr -> Ptr PgfCallbacksMap -> CString -> FunPtr LiteralMatchCallback -> FunPtr LiteralPredictCallback -> Ptr GuPool -> IO ()
 
+type OracleCallback = Ptr PgfOracleCallback -> CString -> CString -> CInt -> IO Bool
+type OracleLiteralCallback = Ptr PgfOracleCallback -> CString -> CString -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb)
+
+foreign import ccall "wrapper"
+  wrapOracleCallback :: OracleCallback -> IO (FunPtr OracleCallback)
+
+foreign import ccall "wrapper"
+  wrapOracleLiteralCallback :: OracleLiteralCallback -> IO (FunPtr OracleLiteralCallback)
+
+foreign import ccall
+  hspgf_new_oracle_callback :: FunPtr OracleCallback -> FunPtr OracleCallback -> FunPtr OracleLiteralCallback -> Ptr GuPool -> IO (Ptr PgfOracleCallback)
+
+foreign import ccall "pgf/pgf.h pgf_parse_with_oracle"
+  pgf_parse_with_oracle :: Ptr PgfConcr -> CString -> CString -> Ptr PgfOracleCallback -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
+
 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 a00527df5..0dd9ae03b 100644
--- a/src/runtime/haskell-bind/utils.c
+++ b/src/runtime/haskell-bind/utils.c
@@ -67,3 +67,33 @@ hspgf_callbacks_map_add_literal(PgfConcr* concr, PgfCallbacksMap* callbacks,
 	gu_pool_finally(pool, &callback->fin);
 	pgf_callbacks_map_add_literal(concr, callbacks, cat, &callback->callback);
 }
+
+typedef struct {
+	PgfOracleCallback oracle;
+	GuFinalizer fin;
+} HSPgfOracleCallback;
+
+static void
+hspgf_oracle_callback_fin(GuFinalizer* self)
+{
+	HSPgfOracleCallback* oracle = gu_container(self, HSPgfOracleCallback, fin);
+
+	if (oracle->oracle.predict  != NULL)
+		hs_free_fun_ptr((HsFunPtr) oracle->oracle.predict);
+	if (oracle->oracle.complete != NULL)
+		hs_free_fun_ptr((HsFunPtr) oracle->oracle.complete);
+	if (oracle->oracle.literal  != NULL)
+		hs_free_fun_ptr((HsFunPtr) oracle->oracle.literal);
+}
+
+PgfOracleCallback*
+hspgf_new_oracle_callback(HsFunPtr predict, HsFunPtr complete, HsFunPtr literal, GuPool* pool)
+{
+	HSPgfOracleCallback* oracle = gu_new(HSPgfOracleCallback, pool);
+	oracle->oracle.predict  = (void*) predict;
+	oracle->oracle.complete = (void*) complete;
+	oracle->oracle.literal  = (void*) literal;
+	oracle->fin.fn = hspgf_oracle_callback_fin;
+	gu_pool_finally(pool, &oracle->fin);
+	return &oracle->oracle;
+}