further extend the API of the C runtime

src/runtime/c/pgf/expr.c

@@ -1650,10 +1650,10 @@ pgf_print_hypo(PgfHypo *hypo, PgfPrintContext* ctxt, int prec,
         } else {
             pgf_print_type(hypo->type, ctxt, prec, out, err);
         }
-        
+
         gu_pool_free(tmp_pool);
     }
-    
+
 	PgfPrintContext* new_ctxt = malloc(sizeof(PgfPrintContext));
 	new_ctxt->name = hypo->cid;
 	new_ctxt->next = ctxt;
@@ -1668,7 +1668,7 @@ pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec,
     
     if (n_hypos > 0) {
 		if (prec > 0) gu_putc('(', out, err);
-		
+
 		PgfPrintContext* new_ctxt = ctxt;
 		for (size_t i = 0; i < n_hypos; i++) {
 			PgfHypo *hypo = gu_seq_index(type->hypos, PgfHypo, i);
@@ -1707,6 +1707,22 @@ pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec,
 	}
 }
 
+PGF_API void
+pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt,
+                  GuOut *out, GuExn *err)
+{
+	PgfPrintContext* new_ctxt = ctxt;
+
+    size_t n_hypos = gu_seq_length(hypos);
+	for (size_t i = 0; i < n_hypos; i++) {
+		if (i > 0)
+			gu_putc(' ', out, err);
+
+		PgfHypo *hypo = gu_seq_index(hypos, PgfHypo, i);
+		new_ctxt = pgf_print_hypo(hypo, new_ctxt, 4, out, err);		
+	}
+}
+
 PGF_API void
 pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
                      GuOut* out, GuExn* err)

src/runtime/c/pgf/expr.h

@@ -234,6 +234,10 @@ PGF_API_DECL void
 pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec,
                GuOut* out, GuExn *err);
 
+PGF_API_DECL void
+pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt,
+                  GuOut *out, GuExn *err);
+
 PGF_API_DECL void
 pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
                      GuOut* out, GuExn* err);

src/runtime/c/pgf/pgf.c

@@ -152,6 +152,17 @@ pgf_category_context(PgfPGF *gr, PgfCId catname)
 	return abscat->context;
 }
 
+PGF_API prob_t
+pgf_category_prob(PgfPGF* pgf, PgfCId catname)
+{
+	PgfAbsCat* abscat =
+		gu_seq_binsearch(pgf->abstract.cats, pgf_abscat_order, PgfAbsCat, catname);
+	if (abscat == NULL)
+		return INFINITY;
+
+	return abscat->prob;
+}
+
 PGF_API GuString
 pgf_language_code(PgfConcr* concr)
 {
@@ -221,7 +232,7 @@ pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname)
 	return (absfun->defns == NULL);
 }
 
-PGF_API double
+PGF_API prob_t
 pgf_function_prob(PgfPGF* pgf, PgfCId funname) 
 {
 	PgfAbsFun* absfun =

src/runtime/c/pgf/pgf.h

@@ -84,6 +84,9 @@ pgf_start_cat(PgfPGF* pgf, GuPool* pool);
 PGF_API_DECL PgfHypos*
 pgf_category_context(PgfPGF *gr, PgfCId catname);
 
+PGF_API_DECL prob_t
+pgf_category_prob(PgfPGF* pgf, PgfCId catname);
+
 PGF_API_DECL void
 pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err);
 
@@ -97,7 +100,7 @@ pgf_function_type(PgfPGF* pgf, PgfCId funname);
 PGF_API_DECL bool
 pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname);
 
-PGF_API_DECL double
+PGF_API_DECL prob_t
 pgf_function_prob(PgfPGF* pgf, PgfCId funname);
 
 PGF_API_DECL GuString

src/runtime/haskell-bind/PGF2.hsc

@@ -45,7 +45,7 @@ module PGF2 (-- * PGF
 
              -- ** Types
              Type, Hypo, BindType(..), startCat,
-             readType, showType,
+             readType, showType, showContext,
              mkType, unType,
 
              -- ** Type checking
@@ -1083,8 +1083,7 @@ categoryContext :: PGF -> Cat -> [Hypo]
 categoryContext p cat =
   unsafePerformIO $
     withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
+      do c_cat <- newUtf8CString cat tmpPl
-         c_cat <- newUtf8CString cat tmpPl
          c_hypos <- pgf_category_context (pgf p) c_cat
          if c_hypos == nullPtr
            then return []
@@ -1104,6 +1103,15 @@ categoryContext p cat =
     toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
     toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
 
+categoryProb :: PGF -> Cat -> Float
+categoryProb p cat =
+  unsafePerformIO $
+    withGuPool $ \tmpPl ->
+      do c_cat <- newUtf8CString cat tmpPl
+         c_prob <- pgf_category_prob (pgf p) c_cat
+         touchPGF p
+         return (realToFrac c_prob)
+
 -----------------------------------------------------------------------------
 -- Helper functions
 

src/runtime/haskell-bind/PGF2/FFI.hsc

@@ -298,6 +298,9 @@ foreign import ccall "pgf/pgf.h pgf_start_cat"
 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_category_prob"
+  pgf_category_prob :: Ptr PgfPGF -> CString -> IO (#type prob_t)
+
 foreign import ccall "pgf/pgf.h pgf_iter_functions"
   pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
 
@@ -485,6 +488,9 @@ foreign import ccall "pgf/expr.h pgf_print_expr_tuple"
 foreign import ccall "pgf/expr.h pgf_print_type"
   pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
 
+foreign import ccall "pgf/expr.h pgf_print_context"
+  pgf_print_context :: Ptr GuSeq -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO ()
+
 foreign import ccall "pgf/pgf.h pgf_generate_all"
   pgf_generate_all :: Ptr PgfPGF -> PgfType -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
 

src/runtime/haskell-bind/PGF2/Type.hsc

@@ -64,8 +64,7 @@ mkType hypos cat exprs = unsafePerformIO $ do
   typPl  <- gu_new_pool
   let n_exprs = fromIntegral (length exprs) :: CSizeT
   c_type <- gu_malloc typPl ((#size PgfType) + n_exprs * (#size PgfExpr))
-  c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) typPl
+  c_hypos <- newSequence (#size PgfHypo) (pokeHypo typPl) hypos typPl
-  hs <- pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos typPl
   (#poke PgfType, hypos) c_type c_hypos
   ccat <- newUtf8CString cat typPl
   (#poke PgfType, cid) c_type ccat
@@ -73,27 +72,25 @@ mkType hypos cat exprs = unsafePerformIO $ do
   pokeExprs (c_type `plusPtr` (#offset PgfType, exprs)) exprs
   typFPl <- newForeignPtr gu_pool_finalizer typPl
   return (Type c_type (mapM_ touchHypo hypos >> mapM_ touchExpr exprs >> touchForeignPtr typFPl))
+
+pokeHypo :: Ptr GuPool -> Ptr a -> Hypo -> IO ()
+pokeHypo pool c_hypo (bind_type,cid,Type c_ty _) = do
+  (#poke PgfHypo, bind_type) c_hypo cbind_type
+  newUtf8CString cid pool >>= (#poke PgfHypo, cid) c_hypo
+  (#poke PgfHypo, type) c_hypo c_ty
   where
-    pokeHypos :: Ptr a -> [Hypo] -> Ptr GuPool -> IO ()
+    cbind_type :: CInt
-    pokeHypos c_hypo []                                    typPl = return ()
+    cbind_type =
-    pokeHypos c_hypo ((bind_type,cid,Type c_ty _) : hypos) typPl = do
+      case bind_type of
-      (#poke PgfHypo, bind_type) c_hypo cbind_type
+        Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
-      newUtf8CString cid typPl >>= (#poke PgfHypo, cid) c_hypo
+        Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
-      (#poke PgfHypo, type) c_hypo c_ty
-      pokeHypos (plusPtr c_hypo (#size PgfHypo)) hypos typPl
-      where
-        cbind_type :: CInt
-        cbind_type =
-          case bind_type of
-            Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
-            Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
 
-    pokeExprs ptr []              = return ()
+pokeExprs ptr []              = return ()
-    pokeExprs ptr ((Expr e _):es) = do
+pokeExprs ptr ((Expr e _):es) = do
-      poke ptr e
+  poke ptr e
-      pokeExprs (plusPtr ptr (#size PgfExpr)) es
+  pokeExprs (plusPtr ptr (#size PgfExpr)) es
-
+    
-    touchHypo (_,_,ty) = touchType ty
+touchHypo (_,_,ty) = touchType ty
 
 -- | Decomposes a type into a list of hypothesises, a category and 
 -- a list of arguments for the category.
@@ -125,3 +122,20 @@ unType (Type c_type touch) = unsafePerformIO $ do
                        es <- peekExprs ptr (i+1) n
                        return (Expr e touch : es)
       | otherwise = return []
+
+-- | renders a type as a 'String'. The list
+-- of identifiers is the list of all free variables
+-- in the type in order reverse to the order
+-- of binding.
+showContext :: [CId] -> [Hypo] -> String
+showContext scope hypos =
+  unsafePerformIO $
+    withGuPool $ \tmpPl ->
+      do (sb,out) <- newOut tmpPl
+         c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl
+         printCtxt <- newPrintCtxt scope tmpPl
+         exn <- gu_new_exn tmpPl
+         pgf_print_context c_hypos printCtxt out exn
+         mapM_ touchHypo hypos
+         s <- gu_string_buf_freeze sb tmpPl
+         peekUtf8CString s

src/runtime/java/jpgf.c

@@ -188,7 +188,7 @@ Java_org_grammaticalframework_pgf_PGF_getFunctionProb(JNIEnv* env, jobject self,
 	PgfPGF* pgf = get_ref(env, self);
 	GuPool* tmp_pool = gu_local_pool();
 	PgfCId id = j2gu_string(env, jid, tmp_pool);
-	double prob = pgf_function_prob(pgf, id);
+	prob_t prob = pgf_function_prob(pgf, id);
 	gu_pool_free(tmp_pool);
 
 	return prob;