diff options
Diffstat (limited to 'src/runtime/haskell-bind')
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 35 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/FFI.hs | 3 |
2 files changed, 29 insertions, 9 deletions
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 54c413a34..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 @@ -212,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 @@ -974,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 @@ -1032,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 @@ -1044,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 65dd81085..f25e52edf 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -346,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 () |