diff options
Diffstat (limited to 'src/runtime/haskell-bind/PGF2.hsc')
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 50 |
1 files changed, 33 insertions, 17 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 |