summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/runtime/c/pgf/expr.c22
-rw-r--r--src/runtime/c/pgf/expr.h4
-rw-r--r--src/runtime/c/pgf/pgf.c13
-rw-r--r--src/runtime/c/pgf/pgf.h5
-rw-r--r--src/runtime/haskell-bind/PGF2.hsc14
-rw-r--r--src/runtime/haskell-bind/PGF2/FFI.hsc6
-rw-r--r--src/runtime/haskell-bind/PGF2/Type.hsc56
-rw-r--r--src/runtime/java/jpgf.c2
8 files changed, 92 insertions, 30 deletions
diff --git a/src/runtime/c/pgf/expr.c b/src/runtime/c/pgf/expr.c
index 5801defef..92e92f04f 100644
--- a/src/runtime/c/pgf/expr.c
+++ b/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);
@@ -1708,6 +1708,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)
{
diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h
index 013de08f4..e560d3a83 100644
--- a/src/runtime/c/pgf/expr.h
+++ b/src/runtime/c/pgf/expr.h
@@ -235,6 +235,10 @@ 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);
diff --git a/src/runtime/c/pgf/pgf.c b/src/runtime/c/pgf/pgf.c
index 6d43eab3b..5317830fb 100644
--- a/src/runtime/c/pgf/pgf.c
+++ b/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 =
diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h
index 908cefa69..d4cc63097 100644
--- a/src/runtime/c/pgf/pgf.h
+++ b/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
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 6ffa6ff37..409283981 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/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
- c_cat <- newUtf8CString cat tmpPl
+ do 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
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc
index fd633435b..c33f1da50 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hsc
+++ b/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)
diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc
index 06b137b1f..57e7eeaa9 100644
--- a/src/runtime/haskell-bind/PGF2/Type.hsc
+++ b/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
- hs <- pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos typPl
+ c_hypos <- newSequence (#size PgfHypo) (pokeHypo typPl) 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))
- where
- pokeHypos :: Ptr a -> [Hypo] -> Ptr GuPool -> IO ()
- pokeHypos c_hypo [] typPl = return ()
- pokeHypos c_hypo ((bind_type,cid,Type c_ty _) : hypos) typPl = do
- (#poke PgfHypo, bind_type) c_hypo cbind_type
- newUtf8CString cid typPl >>= (#poke PgfHypo, cid) c_hypo
- (#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 ((Expr e _):es) = do
- poke ptr e
- pokeExprs (plusPtr ptr (#size PgfExpr)) es
+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
+ cbind_type :: CInt
+ cbind_type =
+ case bind_type of
+ Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
+ Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
- touchHypo (_,_,ty) = touchType ty
+pokeExprs ptr [] = return ()
+pokeExprs ptr ((Expr e _):es) = do
+ poke ptr e
+ pokeExprs (plusPtr ptr (#size PgfExpr)) es
+
+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
diff --git a/src/runtime/java/jpgf.c b/src/runtime/java/jpgf.c
index 1a1d4efba..bdfdc8e8c 100644
--- a/src/runtime/java/jpgf.c
+++ b/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;
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:01:46 +0000