diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 3f3a5bdcf..feab67fb9 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -1,4 +1,5 @@ #include +#include #include "data.h" #include "reader.h" @@ -167,8 +168,8 @@ void pgf_iter_categories(PgfPGF* pgf, PgfItor* itor) namespace_iter(pgf->get_root()->abstract.cats, itor); } -PGF_API PgfTypeHypo* -pgf_category_context(PgfPGF *pgf, PgfText *catname, size_t *n_hypos) +PGF_API +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 abscat = + namespace_lookup(pgf->get_root()->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()->abstract.funs, &helper); } -PGF_API uintptr_t -pgf_function_type(PgfPGF* pgf, PgfText *funname) +PGF_API +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 absfun = + namespace_lookup(pgf->get_root()->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 absfun = + namespace_lookup(pgf->get_root()->abstract.funs, funname); + if (absfun == 0) + return INFINITY; + + return absfun->ep.prob; +} + PGF_API uintptr_t pgf_read_expr(PgfText *input, PgfUnmarshaller *u) { diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 86b81e498..663457833 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/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 -void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfText* cat, PgfItor* itor); +PGF_API_DECL +void pgf_iter_functions_by_cat(PgfPGF *pgf, PgfText *cat, PgfItor *itor); -PGF_API uintptr_t -pgf_read_expr(PgfText *input, PgfUnmarshaller *u); +PGF_API_DECL +uintptr_t pgf_function_type(PgfPGF *pgf, PgfText *funname); -PGF_API uintptr_t -pgf_read_type(PgfText *input, PgfUnmarshaller *u); +PGF_API_DECL +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_ diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 6587addab..aaeac003f 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/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 = diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index fdf1ca225..55e0c8a71 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/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 = diff --git a/src/runtime/haskell/tests/basic.gf b/src/runtime/haskell/tests/basic.gf index b50286ef2..84b6efe80 100644 --- a/src/runtime/haskell/tests/basic.gf +++ b/src/runtime/haskell/tests/basic.gf @@ -2,10 +2,10 @@ abstract basic = { cat N; S ; -fun z : N ; - s : N -> N ; +data z : 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) ; diff --git a/src/runtime/haskell/tests/basic.hs b/src/runtime/haskell/tests/basic.hs index 2cd6b8596..0279099f3 100644 --- a/src/runtime/haskell/tests/basic.hs +++ b/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 diff --git a/src/runtime/haskell/tests/basic.pgf b/src/runtime/haskell/tests/basic.pgf index 61d1b6e01..b0e3398b5 100644 Binary files a/src/runtime/haskell/tests/basic.pgf and b/src/runtime/haskell/tests/basic.pgf differ