in the PGF2 api: remove showCategory. add categoryContext and functionIsConstructor

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