From d5a7945ba0b082a3be8a7cd4b9142e553dbfec9b Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Fri, 1 Sep 2017 09:57:00 +0200
Subject: complete details for the "ai" command in the C shell

---
 src/runtime/c/pgf/expr.c             | 24 ++++++++++++++++++++++++
 src/runtime/c/pgf/expr.h             |  4 ++++
 src/runtime/haskell-bind/PGF2.hsc    | 35 ++++++++++++++++++++++++++---------
 src/runtime/haskell-bind/PGF2/FFI.hs |  3 +++
 4 files changed, 57 insertions(+), 9 deletions(-)

(limited to 'src/runtime')

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 ()
 
-- 
cgit v1.2.3