diff --git a/src/runtime/c/pgf/expr.c b/src/runtime/c/pgf/expr.c index 2a1d0de15..5801defef 100644 --- a/src/runtime/c/pgf/expr.c +++ b/src/runtime/c/pgf/expr.c @@ -1720,30 +1720,6 @@ pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt, gu_putc('>', out, err); } -PGF_API_DECL void -pgf_print_category(PgfPGF *gr, PgfCId catname, - GuOut* out, GuExn *err) -{ - PgfAbsCat* abscat = - gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname); - if (abscat == NULL) { - GuExnData* exn = gu_raise(err, PgfExn); - exn->data = "Unknown category"; - return; - } - - gu_puts(abscat->name, out, err); - - PgfPrintContext* ctxt = NULL; - size_t n_hypos = gu_seq_length(abscat->context); - for (size_t i = 0; i < n_hypos; i++) { - PgfHypo *hypo = gu_seq_index(abscat->context, PgfHypo, i); - - gu_putc(' ', out, err); - ctxt = pgf_print_hypo(hypo, ctxt, 4, out, err); - } -} - PGF_API bool pgf_type_eq(PgfType* t1, PgfType* t2) { diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h index 0fc6774ac..013de08f4 100644 --- a/src/runtime/c/pgf/expr.h +++ b/src/runtime/c/pgf/expr.h @@ -238,11 +238,7 @@ PGF_API_DECL void pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt, GuOut* out, GuExn* err); -PGF_API_DECL void -pgf_print_category(PgfPGF *gr, PgfCId catname, - GuOut* out, GuExn *err); - -PGF_API prob_t +PGF_API_DECL prob_t pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr); #endif /* EXPR_H_ */ diff --git a/src/runtime/c/pgf/pgf.c b/src/runtime/c/pgf/pgf.c index 7e519cbbf..6d43eab3b 100644 --- a/src/runtime/c/pgf/pgf.c +++ b/src/runtime/c/pgf/pgf.c @@ -140,6 +140,18 @@ pgf_start_cat(PgfPGF* pgf, GuPool* pool) return type; } +PGF_API PgfHypos* +pgf_category_context(PgfPGF *gr, PgfCId catname) +{ + PgfAbsCat* abscat = + gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname); + if (abscat == NULL) { + return NULL; + } + + return abscat->context; +} + PGF_API GuString pgf_language_code(PgfConcr* concr) { @@ -173,7 +185,7 @@ pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err) } PGF_API void -pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, +pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, GuMapItor* itor, GuExn* err) { size_t n_funs = gu_seq_length(pgf->abstract.funs); @@ -199,6 +211,16 @@ pgf_function_type(PgfPGF* pgf, PgfCId funname) return absfun->type; } +PGF_API_DECL bool +pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname) +{ + PgfAbsFun* absfun = + gu_seq_binsearch(pgf->abstract.funs, pgf_absfun_order, PgfAbsFun, funname); + if (absfun == NULL) + return false; + return (absfun->defns == NULL); +} + PGF_API double pgf_function_prob(PgfPGF* pgf, PgfCId funname) { diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index c7a14dceb..908cefa69 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -81,6 +81,9 @@ pgf_iter_categories(PgfPGF* pgf, GuMapItor* itor, GuExn* err); PGF_API_DECL PgfType* pgf_start_cat(PgfPGF* pgf, GuPool* pool); +PGF_API_DECL PgfHypos* +pgf_category_context(PgfPGF *gr, PgfCId catname); + PGF_API_DECL void pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err); @@ -91,6 +94,9 @@ pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, PGF_API_DECL PgfType* pgf_function_type(PgfPGF* pgf, PgfCId funname); +PGF_API_DECL bool +pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname); + PGF_API_DECL double pgf_function_prob(PgfPGF* pgf, PgfCId funname); diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 733e29c74..6ffa6ff37 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -27,9 +27,10 @@ module PGF2 (-- * PGF -- * Abstract syntax AbsName,abstractName, -- ** Categories - Cat,categories,showCategory, + Cat,categories,categoryContext, -- ** Functions - Fun,functions, functionsByCat, functionType, hasLinearization, + Fun, functions, functionsByCat, + functionType, functionIsConstructor, hasLinearization, -- ** Expressions Expr,showExpr,readExpr,pExpr, mkAbs,unAbs, @@ -240,6 +241,16 @@ functionType p fn = then Nothing else Just (Type c_type (touchPGF p))) +-- | The type of a function +functionIsConstructor :: PGF -> Fun -> Bool +functionIsConstructor p fn = + unsafePerformIO $ + withGuPool $ \tmpPl -> do + c_fn <- newUtf8CString fn tmpPl + res <- pgf_function_is_constructor (pgf p) c_fn + touchPGF p + return (res /= 0) + -- | Checks an expression against a specified type. checkExpr :: PGF -> Expr -> Type -> Either String Expr checkExpr (PGF p _) (Expr c_expr touch1) (Type c_ty touch2) = @@ -1068,25 +1079,30 @@ categories p = name <- peekUtf8CString (castPtr key) writeIORef ref $! (name : names) -showCategory :: PGF -> Cat -> String -showCategory p cat = +categoryContext :: PGF -> Cat -> [Hypo] +categoryContext p cat = unsafePerformIO $ withGuPool $ \tmpPl -> do (sb,out) <- newOut tmpPl - exn <- gu_new_exn tmpPl c_cat <- newUtf8CString cat tmpPl - pgf_print_category (pgf p) c_cat out exn - touchPGF p - failed <- gu_exn_is_raised exn - if failed - then do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn - if is_exn - then do c_msg <- (#peek GuExn, data.data) exn - msg <- peekUtf8CString c_msg - throwIO (PGFError msg) - else throwIO (PGFError "The abstract tree cannot be linearized") - else do s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s + c_hypos <- pgf_category_context (pgf p) c_cat + if c_hypos == nullPtr + then return [] + else do n_hypos <- (#peek GuSeq, len) c_hypos + peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos + where + peekHypos :: Ptr a -> Int -> Int -> IO [Hypo] + peekHypos c_hypo i n + | i < n = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString + c_ty <- (#peek PgfHypo, type) c_hypo + bt <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo) + hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n + return ((bt,cid,Type c_ty (touchPGF p)) : hs) + | otherwise = return [] + + toBindType :: CInt -> BindType + toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit + toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit ----------------------------------------------------------------------------- -- Helper functions diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc index 71e4b488f..fd633435b 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hsc +++ b/src/runtime/haskell-bind/PGF2/FFI.hsc @@ -295,6 +295,9 @@ foreign import ccall "pgf/pgf.h pgf_iter_categories" foreign import ccall "pgf/pgf.h pgf_start_cat" pgf_start_cat :: Ptr PgfPGF -> Ptr GuPool -> IO PgfType +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_iter_functions" pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () @@ -304,6 +307,9 @@ foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat" foreign import ccall "pgf/pgf.h pgf_function_type" pgf_function_type :: Ptr PgfPGF -> CString -> IO PgfType +foreign import ccall "pgf/expr.h pgf_function_is_constructor" + pgf_function_is_constructor :: Ptr PgfPGF -> CString -> IO (#type bool) + foreign import ccall "pgf/pgf.h pgf_print_name" pgf_print_name :: Ptr PgfConcr -> CString -> IO CString @@ -476,9 +482,6 @@ foreign import ccall "pgf/expr.h pgf_print_expr" foreign import ccall "pgf/expr.h pgf_print_expr_tuple" pgf_print_expr_tuple :: CSizeT -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO () -foreign import ccall "pgf/expr.h pgf_print_category" - pgf_print_category :: Ptr PgfPGF -> CString -> Ptr GuOut -> Ptr GuExn -> IO () - foreign import ccall "pgf/expr.h pgf_print_type" pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()