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) =