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

src/runtime/c/pgf/expr.c

@@ -1720,30 +1720,6 @@ pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
 	gu_putc('>', out, err);
 }
 
-PGF_API_DECL void
-pgf_print_category(PgfPGF *gr, PgfCId catname,
-                   GuOut* out, GuExn *err)
-{
-	PgfAbsCat* abscat =
-		gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname);
-	if (abscat == NULL) {
-		GuExnData* exn = gu_raise(err, PgfExn);
-		exn->data = "Unknown category";
-		return;
-	}
-
-	gu_puts(abscat->name, out, err);
-
-	PgfPrintContext* ctxt = NULL;
-	size_t n_hypos = gu_seq_length(abscat->context);
-	for (size_t i = 0; i < n_hypos; i++) {
-		PgfHypo *hypo = gu_seq_index(abscat->context, PgfHypo, i);
-
-		gu_putc(' ', out, err);
-		ctxt = pgf_print_hypo(hypo, ctxt, 4, out, err);
-	}
-}
-
 PGF_API bool
 pgf_type_eq(PgfType* t1, PgfType* t2)
 {

src/runtime/c/pgf/expr.h

@@ -238,11 +238,7 @@ PGF_API_DECL void
 pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
                      GuOut* out, GuExn* err);
 
-PGF_API_DECL void
+PGF_API_DECL prob_t
-pgf_print_category(PgfPGF *gr, PgfCId catname,
-                   GuOut* out, GuExn *err);
-
-PGF_API prob_t
 pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr);
 
 #endif /* EXPR_H_ */

src/runtime/c/pgf/pgf.c

@@ -140,6 +140,18 @@ pgf_start_cat(PgfPGF* pgf, GuPool* pool)
 	return type;
 }
 
+PGF_API PgfHypos*
+pgf_category_context(PgfPGF *gr, PgfCId catname)
+{
+	PgfAbsCat* abscat =
+		gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname);
+	if (abscat == NULL) {
+		return NULL;
+	}
+
+	return abscat->context;
+}
+
 PGF_API GuString
 pgf_language_code(PgfConcr* concr)
 {
@@ -173,7 +185,7 @@ pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err)
 }
 
 PGF_API void
-pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, 
+pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname,
                           GuMapItor* itor, GuExn* err) 
 {
 	size_t n_funs = gu_seq_length(pgf->abstract.funs);
@@ -199,6 +211,16 @@ pgf_function_type(PgfPGF* pgf, PgfCId funname)
 	return absfun->type;
 }
 
+PGF_API_DECL bool
+pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname)
+{
+	PgfAbsFun* absfun =
+		gu_seq_binsearch(pgf->abstract.funs, pgf_absfun_order, PgfAbsFun, funname);
+	if (absfun == NULL)
+		return false;
+	return (absfun->defns == NULL);
+}
+
 PGF_API double
 pgf_function_prob(PgfPGF* pgf, PgfCId funname) 
 {

src/runtime/c/pgf/pgf.h

@@ -81,6 +81,9 @@ pgf_iter_categories(PgfPGF* pgf, GuMapItor* itor, GuExn* err);
 PGF_API_DECL PgfType*
 pgf_start_cat(PgfPGF* pgf, GuPool* pool);
 
+PGF_API_DECL PgfHypos*
+pgf_category_context(PgfPGF *gr, PgfCId catname);
+
 PGF_API_DECL void
 pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err);
 
@@ -91,6 +94,9 @@ pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname,
 PGF_API_DECL PgfType*
 pgf_function_type(PgfPGF* pgf, PgfCId funname);
 
+PGF_API_DECL bool
+pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname);
+
 PGF_API_DECL double
 pgf_function_prob(PgfPGF* pgf, PgfCId funname);
 

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
+categoryContext :: PGF -> Cat -> [Hypo]
-showCategory p cat =
+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
+         c_hypos <- pgf_category_context (pgf p) c_cat
-         touchPGF p
+         if c_hypos == nullPtr
-         failed <- gu_exn_is_raised exn
+           then return []
-         if failed
+           else do n_hypos <- (#peek GuSeq, len) c_hypos
-           then do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
+                   peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos
-                   if is_exn
+  where
-                     then do c_msg <- (#peek GuExn, data.data) exn
+    peekHypos :: Ptr a -> Int -> Int -> IO [Hypo]
-                             msg <- peekUtf8CString c_msg
+    peekHypos c_hypo i n
-                             throwIO (PGFError msg)
+      | i < n     = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString
-                     else throwIO (PGFError "The abstract tree cannot be linearized")
+                       c_ty <- (#peek PgfHypo, type) c_hypo
-           else do s <- gu_string_buf_freeze sb tmpPl
+                       bt  <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo)
-                   peekUtf8CString s
+                       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

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 ()