added categoryProb, functionProb, functionIsConstructor

src/runtime/c/pgf/pgf.cxx

@@ -1,4 +1,5 @@
 #include <fcntl.h>
+#include <math.h>
 #include "data.h"
 #include "reader.h"
 
@@ -167,8 +168,8 @@ void pgf_iter_categories(PgfPGF* pgf, PgfItor* itor)
     namespace_iter(pgf->get_root<PgfPGFRoot>()->abstract.cats, itor);
 }
 
-PGF_API PgfTypeHypo*
+PGF_API
-pgf_category_context(PgfPGF *pgf, PgfText *catname, size_t *n_hypos)
+PgfTypeHypo *pgf_category_context(PgfPGF *pgf, PgfText *catname, size_t *n_hypos)
 {
     DB_scope scope(pgf, READER_SCOPE);
 
@@ -192,7 +193,21 @@ pgf_category_context(PgfPGF *pgf, PgfText *catname, size_t *n_hypos)
 }
 
 PGF_API
-void pgf_iter_functions(PgfPGF* pgf, PgfItor* itor)
+prob_t pgf_category_prob(PgfPGF *pgf, PgfText *catname)
+{
+    DB_scope scope(pgf, READER_SCOPE);
+
+    ref<PgfAbsCat> abscat =
+        namespace_lookup(pgf->get_root<PgfPGFRoot>()->abstract.cats, catname);
+	if (abscat == 0) {
+		return 0;
+    }
+
+    return abscat->prob;
+}
+
+PGF_API
+void pgf_iter_functions(PgfPGF *pgf, PgfItor *itor)
 {
     DB_scope scope(pgf, READER_SCOPE);
 
@@ -206,7 +221,7 @@ struct PgfItorHelper : PgfItor
 };
 
 static
-void iter_by_cat_helper(PgfItor* itor, PgfText* key, void* value)
+void iter_by_cat_helper(PgfItor *itor, PgfText *key, void *value)
 {
     PgfItorHelper* helper = (PgfItorHelper*) itor;
     PgfAbsFun* absfun = (PgfAbsFun*) value;
@@ -215,7 +230,7 @@ void iter_by_cat_helper(PgfItor* itor, PgfText* key, void* value)
 }
 
 PGF_API
-void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfText* cat, PgfItor* itor)
+void pgf_iter_functions_by_cat(PgfPGF *pgf, PgfText *cat, PgfItor *itor)
 {
     DB_scope scope(pgf, READER_SCOPE);
 
@@ -226,8 +241,8 @@ void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfText* cat, PgfItor* itor)
     namespace_iter(pgf->get_root<PgfPGFRoot>()->abstract.funs, &helper);
 }
 
-PGF_API uintptr_t
+PGF_API
-pgf_function_type(PgfPGF* pgf, PgfText *funname)
+uintptr_t pgf_function_type(PgfPGF *pgf, PgfText *funname)
 {
     DB_scope scope(pgf, READER_SCOPE);
 
@@ -239,6 +254,32 @@ pgf_function_type(PgfPGF* pgf, PgfText *funname)
 	return pgf_unmarshall_type(pgf->u, absfun->type);
 }
 
+PGF_API
+int pgf_function_is_constructor(PgfPGF *pgf, PgfText *funname)
+{
+    DB_scope scope(pgf, READER_SCOPE);
+
+    ref<PgfAbsFun> absfun =
+        namespace_lookup(pgf->get_root<PgfPGFRoot>()->abstract.funs, funname);
+	if (absfun == 0)
+		return false;
+
+	return (absfun->defns == 0);
+}
+
+PGF_API
+prob_t pgf_function_prob(PgfPGF *pgf, PgfText *funname)
+{
+    DB_scope scope(pgf, READER_SCOPE);
+
+    ref<PgfAbsFun> absfun =
+        namespace_lookup(pgf->get_root<PgfPGFRoot>()->abstract.funs, funname);
+	if (absfun == 0)
+		return INFINITY;
+
+	return absfun->ep.prob;
+}
+
 PGF_API uintptr_t
 pgf_read_expr(PgfText *input, PgfUnmarshaller *u)
 {

src/runtime/c/pgf/pgf.h

@@ -96,6 +96,8 @@ struct PgfUnmarshaller {
     void (*free_me)(PgfUnmarshaller *unmarshaller);
 };
 
+typedef float prob_t;
+
 typedef struct PgfPGF PgfPGF;
 
 /* All functions that may fail take a reference to a PgfExn structure.
@@ -163,16 +165,28 @@ void pgf_iter_categories(PgfPGF* pgf, PgfItor* itor);
 PGF_API_DECL PgfTypeHypo*
 pgf_category_context(PgfPGF *pgf, PgfText *catname, size_t *n_hypos);
 
+PGF_API_DECL prob_t
+pgf_category_prob(PgfPGF* pgf, PgfText *catname);
+
 PGF_API_DECL
-void pgf_iter_functions(PgfPGF* pgf, PgfItor* itor);
+void pgf_iter_functions(PgfPGF *pgf, PgfItor *itor);
 
-PGF_API
+PGF_API_DECL
-void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfText* cat, PgfItor* itor);
+void pgf_iter_functions_by_cat(PgfPGF *pgf, PgfText *cat, PgfItor *itor);
 
-PGF_API uintptr_t
+PGF_API_DECL
-pgf_read_expr(PgfText *input, PgfUnmarshaller *u);
+uintptr_t pgf_function_type(PgfPGF *pgf, PgfText *funname);
 
-PGF_API uintptr_t
+PGF_API_DECL
-pgf_read_type(PgfText *input, PgfUnmarshaller *u);
+int pgf_function_is_constructor(PgfPGF *pgf, PgfText *funname);
+
+PGF_API_DECL
+prob_t pgf_function_prob(PgfPGF *pgf, PgfText *funname);
+
+PGF_API_DECL
+uintptr_t pgf_read_expr(PgfText *input, PgfUnmarshaller *u);
+
+PGF_API_DECL
+uintptr_t pgf_read_type(PgfText *input, PgfUnmarshaller *u);
 
 #endif // PGF_H_

src/runtime/haskell/PGF2.hsc

@@ -19,10 +19,10 @@ module PGF2 (-- * PGF
              -- * Abstract syntax
              AbsName,abstractName,
              -- ** Categories
-             Cat,categories,categoryContext,
+             Cat,categories,categoryContext,categoryProb,
              -- ** Functions
              Fun, functions, functionsByCat,
-             functionType,
+             functionType, functionIsConstructor, functionProb,
              -- ** Expressions
              Expr(..), Literal(..),
              readExpr,
@@ -144,6 +144,22 @@ functionType p fn =
               freeStablePtr c_typ
               return (Just typ)
 
+functionIsConstructor :: PGF -> Fun -> Bool
+functionIsConstructor p fun =
+  unsafePerformIO $
+  withText fun $ \c_fun ->
+  withForeignPtr (a_pgf p) $ \c_pgf ->
+      do res <- pgf_function_is_constructor c_pgf c_fun
+         return (res /= 0)
+
+functionProb :: PGF -> Fun -> Float
+functionProb p fun =
+  unsafePerformIO $
+  withText fun $ \c_fun ->
+  withForeignPtr (a_pgf p) $ \c_pgf ->
+      do c_prob <- pgf_function_prob c_pgf c_fun
+         return (realToFrac c_prob)
+
 -- | List of all functions defined in the abstract syntax
 categories :: PGF -> [Fun]
 categories p =
@@ -191,6 +207,14 @@ categoryContext p cat =
                        return ((bt,cat,ty) : hs)
       | otherwise = return []
 
+categoryProb :: PGF -> Cat -> Float
+categoryProb p cat =
+  unsafePerformIO $
+  withText cat $ \c_cat ->
+  withForeignPtr (a_pgf p) $ \c_pgf ->
+      do c_prob <- pgf_category_prob c_pgf c_cat
+         return (realToFrac c_prob)
+
 -- | List of all functions defined in the abstract syntax
 functions :: PGF -> [Fun]
 functions p =

src/runtime/haskell/PGF2/FFI.hsc

@@ -66,6 +66,9 @@ foreign import ccall "pgf_iter_categories"
 foreign import ccall "pgf/pgf.h pgf_category_context"
   pgf_category_context :: Ptr PgfPGF -> Ptr PgfText -> Ptr CSize -> IO (Ptr PgfTypeHypo)
 
+foreign import ccall "pgf/pgf.h pgf_category_prob"
+  pgf_category_prob :: Ptr PgfPGF -> Ptr PgfText -> IO (#type prob_t)
+
 foreign import ccall "pgf_iter_functions"
   pgf_iter_functions :: Ptr PgfPGF -> Ptr PgfItor -> IO ()
 
@@ -75,6 +78,11 @@ foreign import ccall "pgf_iter_functions_by_cat"
 foreign import ccall "pgf/pgf.h pgf_function_type"
    pgf_function_type :: Ptr PgfPGF -> Ptr PgfText -> IO (StablePtr Type)
 
+foreign import ccall "pgf/expr.h pgf_function_is_constructor"
+   pgf_function_is_constructor :: Ptr PgfPGF -> Ptr PgfText -> IO (#type int)
+
+foreign import ccall "pgf/expr.h pgf_function_is_constructor"
+   pgf_function_prob :: Ptr PgfPGF -> Ptr PgfText -> IO (#type prob_t)
 
 peekText :: Ptr PgfText -> IO String
 peekText ptr =

src/runtime/haskell/tests/basic.gf

@@ -2,10 +2,10 @@ abstract basic = {
 
 cat N; S ;
 
-fun z : N ;
+data z : N ;
-    s : N -> N ;
+     s : N -> N ;
 
-fun c : N -> S ;
+data c : N -> S ;
 
 cat P N ;
 fun ind : P z -> ((x:N) -> P x -> P (s x)) -> ((x : N) -> P x) ;

src/runtime/haskell/tests/basic.hs

@@ -17,6 +17,10 @@ main = do
              ,TestCase (assertEqual "category context 1"  [] (categoryContext gr "S"))
              ,TestCase (assertEqual "category context 1"  [(Explicit,"_",DTyp [] "N" [])] (categoryContext gr "P"))
              ,TestCase (assertEqual "category context 1"  [] (categoryContext gr "X")) -- no such category
+             ,TestCase (assertEqual "function is constructor 1"  True  (functionIsConstructor gr "s"))
+             ,TestCase (assertEqual "function is constructor 2"  True  (functionIsConstructor gr "z"))
+             ,TestCase (assertEqual "function is constructor 3"  True  (functionIsConstructor gr "c"))
+             ,TestCase (assertEqual "function is constructor 4"  False (functionIsConstructor gr "ind"))
              ]
 
 eqJust (Just x) (Just y) = x == y