diff options
Diffstat (limited to 'src/runtime/haskell-bind')
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 44 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/FFI.hs | 6 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/Type.hsc | 2 |
3 files changed, 42 insertions, 10 deletions
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 4523279dd..037145ee6 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -27,7 +27,7 @@ module PGF2 (-- * PGF -- * Abstract syntax AbsName,abstractName, -- ** Categories - Cat,categories, + Cat,categories,showCategory, -- ** Functions Fun,functions, functionsByCat, functionType, hasLinearization, -- ** Expressions @@ -39,6 +39,8 @@ module PGF2 (-- * PGF mkFloat,unFloat, mkMeta,unMeta, mkCId, + treeProbability, + -- ** Types Type, Hypo, BindType(..), startCat, readType, showType, @@ -210,15 +212,15 @@ unloadConcr :: Concr -> IO () unloadConcr c = pgf_concrete_unload (concr c) -- | The type of a function -functionType :: PGF -> Fun -> Type +functionType :: PGF -> Fun -> Maybe Type functionType p fn = unsafePerformIO $ withGuPool $ \tmpPl -> do c_fn <- newUtf8CString fn tmpPl c_type <- pgf_function_type (pgf p) c_fn - if c_type == nullPtr - then throwIO (PGFError ("Function '"++fn++"' is not defined")) - else return (Type c_type (touchPGF p)) + return (if c_type == nullPtr + then Nothing + else Just (Type c_type (touchPGF p))) -- | Checks an expression against a specified type. checkExpr :: PGF -> Expr -> Type -> Either String Expr @@ -314,6 +316,13 @@ compute (PGF p _) (Expr c_expr touch1) = gu_pool_free exprPl throwIO (PGFError msg) +treeProbability :: PGF -> Expr -> Float +treeProbability (PGF p _) (Expr c_expr touch1) = + unsafePerformIO $ do + res <- pgf_compute_tree_probability p c_expr + touch1 + return (realToFrac res) + ----------------------------------------------------------------------------- -- Graphviz @@ -965,8 +974,25 @@ categories p = name <- peekUtf8CString (castPtr key) writeIORef ref $! (name : names) -categoryContext :: PGF -> Cat -> Maybe [Hypo] -categoryContext pgf cat = Nothing -- !!! not implemented yet TODO +showCategory :: PGF -> Cat -> String +showCategory p cat = + unsafePerformIO $ + withGuPool $ \tmpPl -> + do (sb,out) <- newOut tmpPl + exn <- gu_new_exn tmpPl + c_cat <- newUtf8CString cat tmpPl + pgf_print_category (pgf p) c_cat out exn + touchPGF p + failed <- gu_exn_is_raised exn + if failed + then do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn + if is_exn + then do c_msg <- (#peek GuExn, data.data) exn + msg <- peekUtf8CString c_msg + throwIO (PGFError msg) + else throwIO (PGFError "The abstract tree cannot be linearized") + else do s <- gu_string_buf_freeze sb tmpPl + peekUtf8CString s ----------------------------------------------------------------------------- -- Helper functions @@ -1023,7 +1049,7 @@ nerc pgf (lang,concr) sentence lin_idx offset = ((lemma,cat),_) = maximumBy (compare `on` snd) (reverse ls) ls = [((fun,cat),p) |(fun,_,p)<-lookupMorpho concr name, - let cat=functionCat fun, + Just cat <- [functionCat fun], cat/="Nationality"] name = trimRight (concat capwords) _ -> Nothing @@ -1035,7 +1061,7 @@ nerc pgf (lang,concr) sentence lin_idx offset = Just (y,xs') -> (y:ys,xs'') where (ys,xs'') = consume munch xs' - functionCat f = case unType (functionType pgf f) of (_,cat,_) -> cat + functionCat f = fmap ((\(_,c,_) -> c) . unType) (functionType pgf f) -- | Callback to parse arbitrary words as chunks (from -- ../java/org/grammaticalframework/pgf/UnknownLiteralCallback.java) diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index 1a5e7f91b..f25e52edf 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -325,6 +325,9 @@ foreign import ccall "pgf/pgf.h pgf_expr_unlit" foreign import ccall "pgf/expr.h pgf_expr_arity" pgf_expr_arity :: PgfExpr -> IO CInt +foreign import ccall "pgf/expr.h pgf_compute_tree_probability" + pgf_compute_tree_probability :: Ptr PgfPGF -> PgfExpr -> IO CFloat + foreign import ccall "pgf/expr.h pgf_check_expr" pgf_check_expr :: Ptr PgfPGF -> Ptr PgfExpr -> PgfType -> Ptr GuExn -> Ptr GuPool -> IO () @@ -343,6 +346,9 @@ foreign import ccall "pgf/expr.h pgf_print_expr" foreign import ccall "pgf/expr.h pgf_print_expr_tuple" pgf_print_expr_tuple :: CInt -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO () +foreign import ccall "pgf/expr.h pgf_print_category" + pgf_print_category :: Ptr PgfPGF -> CString -> Ptr GuOut -> Ptr GuExn -> IO () + foreign import ccall "pgf/expr.h pgf_print_type" pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO () diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc index 7b4560abe..ada2b5e03 100644 --- a/src/runtime/haskell-bind/PGF2/Type.hsc +++ b/src/runtime/haskell-bind/PGF2/Type.hsc @@ -50,7 +50,7 @@ showType scope (Type ty touch) = do (sb,out) <- newOut tmpPl printCtxt <- newPrintCtxt scope tmpPl exn <- gu_new_exn tmpPl - pgf_print_type ty printCtxt 1 out exn + pgf_print_type ty printCtxt 0 out exn touch s <- gu_string_buf_freeze sb tmpPl peekUtf8CString s |