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); @@ -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) 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 @@ -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); 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)) + +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 () - 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) + 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 - - 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;