diff --git a/doc/runtime-api.html b/doc/runtime-api.html
index b5ff682c7..966f5f15c 100644
--- a/doc/runtime-api.html
+++ b/doc/runtime-api.html
@@ -894,7 +894,7 @@ Det -> CN -> NP
Prelude PGF2> print (functionType gr "DetCN")
-Det -> CN -> NP
+Just (Det -> CN -> NP)
System.out.println(gr.getFunctionType("DetCN"));
diff --git a/src/compiler/GF/Command/Commands2.hs b/src/compiler/GF/Command/Commands2.hs
index 8a722824e..bc016838d 100644
--- a/src/compiler/GF/Command/Commands2.hs
+++ b/src/compiler/GF/Command/Commands2.hs
@@ -634,18 +634,17 @@ pgfCommands = Map.fromList [
exec = needPGF $ \opts args env@(pgf,cncs) ->
case map cExpr (toExprs args) of
[e] -> case unApp e of
- Just (id,[]) | id `elem` funs -> return (fromString (showFun pgf id))
- | id `elem` cats -> return (fromString (showCat id))
- where
- funs = functions pgf
- cats = categories pgf
-
- showCat c = "cat "++c -- TODO: show categoryContext
- ++"\n\n"++
- unlines [showFun' f ty|f<-funs,
- let ty=functionType pgf f,
- target ty == c]
- target t = case unType t of (_,c,_) -> c
+ Just (id,[]) -> return (fromString
+ (case functionType pgf id of
+ Just ty -> showFun id ty
+ Nothing -> let funs = functionsByCat pgf id
+ in showCat id funs))
+ where
+ showCat c funs = "cat "++showCategory pgf c++
+ " ;\n\n"++
+ unlines [showFun f ty| f<-funs,
+ Just ty <- [functionType pgf f]]
+ showFun f ty = "fun "++f++" : "++showType [] ty++" ;"
_ -> case inferExpr pgf e of
Left msg -> error msg
Right (e,ty) -> do putStrLn ("Expression: "++PGF2.showExpr [] e)
@@ -758,8 +757,7 @@ pgfCommands = Map.fromList [
prGrammar env@(pgf,cncs) opts
| isOpt "langs" opts = return . fromString . unwords $ (map fst (optConcs env opts))
| isOpt "cats" opts = return . fromString . unwords $ categories pgf
- | isOpt "funs" opts = return . fromString . unlines . map (showFun pgf) $
- functions pgf
+ | isOpt "funs" opts = return . fromString . unwords $ functions pgf
| isOpt "missing" opts = return . fromString . unwords $
[f | f <- functions pgf, not (and [hasLinearization concr f | (_,concr) <- optConcs env opts])]
| isOpt "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . snd) $ optConcs env opts
@@ -767,9 +765,6 @@ pgfCommands = Map.fromList [
| isOpt "lexc" opts = return $ fromString $ concatMap (prLexcLexicon . snd) $ optConcs env opts
| otherwise = return void
- showFun pgf f = showFun' f (functionType pgf f)
- showFun' f ty = "fun "++f++" : "++showType [] ty
-
gizaAlignment pgf src_cnc tgt_cnc e =
let src_res = alignWords src_cnc e
tgt_res = alignWords tgt_cnc e
diff --git a/src/runtime/c/pgf/expr.c b/src/runtime/c/pgf/expr.c
index c1f803385..4e9f5ca89 100644
--- a/src/runtime/c/pgf/expr.c
+++ b/src/runtime/c/pgf/expr.c
@@ -1467,6 +1467,30 @@ 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 7f8746b28..e28db7f31 100644
--- a/src/runtime/c/pgf/expr.h
+++ b/src/runtime/c/pgf/expr.h
@@ -226,6 +226,10 @@ 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_compute_tree_probability(PgfPGF *gr, PgfExpr expr);
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 54c413a34..037145ee6 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -27,7 +27,7 @@ module PGF2 (-- * PGF
-- * Abstract syntax
AbsName,abstractName,
-- ** Categories
- Cat,categories,
+ Cat,categories,showCategory,
-- ** Functions
Fun,functions, functionsByCat, functionType, hasLinearization,
-- ** Expressions
@@ -212,15 +212,15 @@ unloadConcr :: Concr -> IO ()
unloadConcr c = pgf_concrete_unload (concr c)
-- | The type of a function
-functionType :: PGF -> Fun -> Type
+functionType :: PGF -> Fun -> Maybe Type
functionType p fn =
unsafePerformIO $
withGuPool $ \tmpPl -> do
c_fn <- newUtf8CString fn tmpPl
c_type <- pgf_function_type (pgf p) c_fn
- if c_type == nullPtr
- then throwIO (PGFError ("Function '"++fn++"' is not defined"))
- else return (Type c_type (touchPGF p))
+ return (if c_type == nullPtr
+ then Nothing
+ else Just (Type c_type (touchPGF p)))
-- | Checks an expression against a specified type.
checkExpr :: PGF -> Expr -> Type -> Either String Expr
@@ -974,8 +974,25 @@ categories p =
name <- peekUtf8CString (castPtr key)
writeIORef ref $! (name : names)
-categoryContext :: PGF -> Cat -> Maybe [Hypo]
-categoryContext pgf cat = Nothing -- !!! not implemented yet TODO
+showCategory :: PGF -> Cat -> String
+showCategory 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
-----------------------------------------------------------------------------
-- Helper functions
@@ -1032,7 +1049,7 @@ nerc pgf (lang,concr) sentence lin_idx offset =
((lemma,cat),_) = maximumBy (compare `on` snd) (reverse ls)
ls = [((fun,cat),p)
|(fun,_,p)<-lookupMorpho concr name,
- let cat=functionCat fun,
+ Just cat <- [functionCat fun],
cat/="Nationality"]
name = trimRight (concat capwords)
_ -> Nothing
@@ -1044,7 +1061,7 @@ nerc pgf (lang,concr) sentence lin_idx offset =
Just (y,xs') -> (y:ys,xs'')
where (ys,xs'') = consume munch xs'
- functionCat f = case unType (functionType pgf f) of (_,cat,_) -> cat
+ functionCat f = fmap ((\(_,c,_) -> c) . unType) (functionType pgf f)
-- | Callback to parse arbitrary words as chunks (from
-- ../java/org/grammaticalframework/pgf/UnknownLiteralCallback.java)
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs
index 65dd81085..f25e52edf 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -346,6 +346,9 @@ foreign import ccall "pgf/expr.h pgf_print_expr"
foreign import ccall "pgf/expr.h pgf_print_expr_tuple"
pgf_print_expr_tuple :: CInt -> 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 ()