complete details for the "ai" command in the C shell

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)

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 ()