diff options
Diffstat (limited to 'src/runtime/haskell-bind')
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 50 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/FFI.hsc | 9 |
2 files changed, 39 insertions, 20 deletions
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 733e29c74..6ffa6ff37 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -27,9 +27,10 @@ module PGF2 (-- * PGF -- * Abstract syntax AbsName,abstractName, -- ** Categories - Cat,categories,showCategory, + Cat,categories,categoryContext, -- ** Functions - Fun,functions, functionsByCat, functionType, hasLinearization, + Fun, functions, functionsByCat, + functionType, functionIsConstructor, hasLinearization, -- ** Expressions Expr,showExpr,readExpr,pExpr, mkAbs,unAbs, @@ -240,6 +241,16 @@ functionType p fn = then Nothing else Just (Type c_type (touchPGF p))) +-- | The type of a function +functionIsConstructor :: PGF -> Fun -> Bool +functionIsConstructor p fn = + unsafePerformIO $ + withGuPool $ \tmpPl -> do + c_fn <- newUtf8CString fn tmpPl + res <- pgf_function_is_constructor (pgf p) c_fn + touchPGF p + return (res /= 0) + -- | Checks an expression against a specified type. checkExpr :: PGF -> Expr -> Type -> Either String Expr checkExpr (PGF p _) (Expr c_expr touch1) (Type c_ty touch2) = @@ -1068,25 +1079,30 @@ categories p = name <- peekUtf8CString (castPtr key) writeIORef ref $! (name : names) -showCategory :: PGF -> Cat -> String -showCategory p cat = +categoryContext :: PGF -> Cat -> [Hypo] +categoryContext 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 + c_hypos <- pgf_category_context (pgf p) c_cat + if c_hypos == nullPtr + then return [] + else do n_hypos <- (#peek GuSeq, len) c_hypos + peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos + where + peekHypos :: Ptr a -> Int -> Int -> IO [Hypo] + peekHypos c_hypo i n + | i < n = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString + c_ty <- (#peek PgfHypo, type) c_hypo + bt <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo) + hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n + return ((bt,cid,Type c_ty (touchPGF p)) : hs) + | otherwise = return [] + + toBindType :: CInt -> BindType + toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit + toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit ----------------------------------------------------------------------------- -- Helper functions diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc index 71e4b488f..fd633435b 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hsc +++ b/src/runtime/haskell-bind/PGF2/FFI.hsc @@ -295,6 +295,9 @@ foreign import ccall "pgf/pgf.h pgf_iter_categories" foreign import ccall "pgf/pgf.h pgf_start_cat" pgf_start_cat :: Ptr PgfPGF -> Ptr GuPool -> IO PgfType +foreign import ccall "pgf/pgf.h pgf_category_context" + pgf_category_context :: Ptr PgfPGF -> CString -> IO (Ptr GuSeq) + foreign import ccall "pgf/pgf.h pgf_iter_functions" pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () @@ -304,6 +307,9 @@ foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat" foreign import ccall "pgf/pgf.h pgf_function_type" pgf_function_type :: Ptr PgfPGF -> CString -> IO PgfType +foreign import ccall "pgf/expr.h pgf_function_is_constructor" + pgf_function_is_constructor :: Ptr PgfPGF -> CString -> IO (#type bool) + foreign import ccall "pgf/pgf.h pgf_print_name" pgf_print_name :: Ptr PgfConcr -> CString -> IO CString @@ -476,9 +482,6 @@ foreign import ccall "pgf/expr.h pgf_print_expr" foreign import ccall "pgf/expr.h pgf_print_expr_tuple" pgf_print_expr_tuple :: CSizeT -> 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 () |