added commands create cat & drop cat

src/compiler/GF/Command/Abstract.hs

@@ -1,6 +1,6 @@
 module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Literal(..),Term) where
 
-import PGF2(Expr,showExpr,Literal(..),Type)
+import PGF2
 import GF.Grammar.Grammar(Term)
 
 type Ident = String
@@ -14,8 +14,10 @@ data Command
    deriving Show
 
 data TransactionCommand
-   = CreateFun [Option] Ident Type
-   | DropFun [Option] Ident
+   = CreateFun [Option] Fun Type
+   | CreateCat [Option] Cat [Hypo]
+   | DropFun [Option] Fun
+   | DropCat [Option] Cat
    deriving Show
 
 data Option

src/compiler/GF/Command/Parse.hs

@@ -1,7 +1,7 @@
 module GF.Command.Parse(readCommandLine, readTransactionCommand, pCommand) where
 
 import PGF(pExpr,pIdent)
-import PGF2(readType)
+import PGF2(readType,readContext)
 import GF.Grammar.Parser(runPartial,pTerm)
 import GF.Command.Abstract
 
@@ -63,6 +63,16 @@ pTransactionCommand = do
           | take 1 cmd == "d" -> do
                 f <- pIdent
                 return (DropFun opts f)
+    "cat" | take 1 cmd == "c" -> do
+               c <- pIdent
+               skipSpaces
+               ctxt <- readS_to_P (\s -> case readContext s of
+                                           Just ty -> [(ty,"")]
+                                           Nothing -> [])
+               return (CreateCat opts c ctxt)
+          | take 1 cmd == "d" -> do
+                c <- pIdent
+                return (DropCat opts c)
     _     -> pfail
 
 pOption = do

src/compiler/GF/Interactive.hs

@@ -236,9 +236,18 @@ transactionCommand (CreateFun opts f ty) pgf = do
     Left msg -> putStrLnE msg
     Right ty -> do lift $ modifyPGF pgf (createFunction f ty 0 [] prob)
                    return ()
+transactionCommand (CreateCat opts c ctxt) pgf = do
+  let prob = realToFrac (valFltOpts "prob" (1/0) opts)
+  case checkContext pgf ctxt of
+    Left msg -> putStrLnE msg
+    Right ty -> do lift $ modifyPGF pgf (createCategory c ctxt prob)
+                   return ()
 transactionCommand (DropFun opts f) pgf = do
   lift $ modifyPGF pgf (dropFunction f)
   return ()
+transactionCommand (DropCat opts c) pgf = do
+  lift $ modifyPGF pgf (dropCategory c)
+  return ()
 
 -- | Commands that work on 'GFEnv'
 moreCommands = [

src/runtime/c/pgf/expr.cxx

@@ -1025,6 +1025,72 @@ exit:
     return type;
 }
 
+PgfTypeHypo *PgfExprParser::parse_context(size_t *p_n_hypos)
+{
+    size_t n_hypos = 0;
+    PgfTypeHypo *hypos = NULL;
+
+	for (;;) {
+		if (token_tag == PGF_TOKEN_LPAR) {
+			token();
+
+            size_t n_start = n_hypos;
+
+			if ((token_tag == PGF_TOKEN_IDENT &&
+			     (lookahead(',') ||
+				  lookahead(':'))) ||
+				(token_tag == PGF_TOKEN_LCURLY) ||
+				(token_tag == PGF_TOKEN_WILD)) {
+
+				if (!parse_hypos(&n_hypos, &hypos))
+					goto exit;
+
+				if (token_tag != PGF_TOKEN_COLON)
+					goto exit;
+
+				token();
+			} else {
+                hypos = (PgfTypeHypo*) realloc(hypos, sizeof(PgfTypeHypo)*(n_hypos+1));
+                PgfTypeHypo *bt = &hypos[n_hypos];
+                bt->bind_type = PGF_BIND_TYPE_EXPLICIT;
+                bt->cid  = mk_wildcard();
+                bt->type = 0;
+                n_hypos++;
+			}
+
+            size_t n_end = n_hypos;
+
+			PgfType type = parse_type();
+			if (type == 0)
+				goto exit;
+
+			if (token_tag != PGF_TOKEN_RPAR)
+				goto exit;
+
+			token();
+
+			for (size_t i = n_start; i < n_end; i++) {
+				hypos[i].type = type;
+			}
+		} else if (token_tag == PGF_TOKEN_IDENT) {
+            hypos = (PgfTypeHypo*) realloc(hypos, sizeof(PgfTypeHypo)*(n_hypos+1));
+            PgfTypeHypo *bt = &hypos[n_hypos];
+            bt->bind_type = PGF_BIND_TYPE_EXPLICIT;
+            bt->cid  = mk_wildcard();
+            bt->type = u->dtyp(0,NULL,token_value,0,NULL);
+            n_hypos++;
+
+            token();
+		} else {
+            goto exit;
+        }
+	}
+
+exit:
+    *p_n_hypos = n_hypos;
+    return hypos;
+}
+
 PgfExpr PgfExprProbEstimator::eabs(PgfBindType bind_type, PgfText *name, PgfExpr body)
 {
     m->match_expr(this, body);

src/runtime/c/pgf/expr.h

@@ -185,6 +185,7 @@ public:
 
     bool parse_hypos(size_t *n_hypos, PgfTypeHypo **hypos);
     PgfType parse_type();
+    PgfTypeHypo *parse_context(size_t *p_n_hypos);
 
     bool eof();
 

src/runtime/c/pgf/pgf.cxx

@@ -718,6 +718,22 @@ PgfType pgf_read_type(PgfText *input, PgfUnmarshaller *u)
     return res;
 }
 
+PGF_API
+PgfTypeHypo *pgf_read_context(PgfText *input, PgfUnmarshaller *u, size_t *n_hypos)
+{
+    PgfExprParser parser(input, u);
+    PgfTypeHypo *res = parser.parse_context(n_hypos);
+    if (!parser.eof()) {
+        for (size_t i = 0; i < *n_hypos; i++) {
+            free(res[i].cid);
+            u->free_ref(res[i].type);
+        }
+        *n_hypos = (size_t) -1;
+        return NULL;
+    }
+    return res;
+}
+
 PGF_API
 PgfText *pgf_print_category_internal(object o)
 {

src/runtime/c/pgf/pgf.h

@@ -376,7 +376,10 @@ PgfText *pgf_print_context(size_t n_hypos, PgfTypeHypo *hypos,
 PGF_API_DECL
 PgfType pgf_read_type(PgfText *input, PgfUnmarshaller *u);
 
-PGF_API
+PGF_API_DECL
+PgfTypeHypo *pgf_read_context(PgfText *input, PgfUnmarshaller *u, size_t *n_hypos);
+
+PGF_API_DECL
 PgfText *pgf_print_start_cat_internal(PgfDB *db, PgfRevision revision, PgfExn *err);
 
 PGF_API_DECL

src/runtime/haskell/PGF2.hsc

@@ -41,14 +41,14 @@ module PGF2 (-- * PGF
 
              -- ** Types
              Type(..), Hypo, BindType(..), startCat,
-             readType, showType, showContext,
+             readType, showType, readContext, showContext,
              mkType, unType,
              mkHypo, mkDepHypo, mkImplHypo,
 
              -- ** Type checking
              -- | Dynamically-built expressions should always be type-checked before using in other functions,
              -- as the exceptions thrown by using invalid expressions may not catchable.
-             checkExpr, inferExpr, checkType,
+             checkExpr, inferExpr, checkType, checkContext,
 
              -- ** Computing
              compute,
@@ -406,7 +406,12 @@ inferExpr p e =
 -- syntax of the grammar.
 checkType :: PGF -> Type -> Either String Type
 checkType pgf ty = Right ty
-  
+
+-- | Check whether a context is consistent with the abstract
+-- syntax of the grammar.
+checkContext :: PGF -> [Hypo] -> Either String [Hypo]
+checkContext pgf ctxt = Right ctxt
+
 compute :: PGF -> Expr -> Expr
 compute = error "TODO: compute"
 
@@ -1334,6 +1339,38 @@ readType str =
               freeStablePtr c_ty
               return (Just ty)
 
+readContext :: String -> Maybe [Hypo]
+readContext str =
+  unsafePerformIO $
+  withText str $ \c_str ->
+  withForeignPtr unmarshaller $ \u ->
+  alloca $ \p_n_hypos -> do
+    c_hypos <- pgf_read_context c_str u p_n_hypos
+    n_hypos <- peek p_n_hypos
+    if c_hypos == nullPtr && n_hypos /= 0
+      then return Nothing
+      else do hypos <- peekHypos (castPtrToStablePtr nullPtr) n_hypos c_hypos
+              free c_hypos
+              return (Just hypos)
+  where
+    peekHypos last 0       p_hypo = do
+      if last /= castPtrToStablePtr nullPtr
+        then freeStablePtr last
+        else return ()
+      return []
+    peekHypos last n_hypos p_hypo = do
+      bt  <- fmap unmarshalBindType ((#peek PgfTypeHypo, bind_type) p_hypo)
+      c_cid <- (#peek PgfTypeHypo, cid) p_hypo
+      cid <- peekText c_cid
+      free c_cid
+      c_ty <- (#peek PgfTypeHypo, type) p_hypo
+      ty <- deRefStablePtr c_ty
+      if last /= c_ty
+        then freeStablePtr last
+        else return ()
+      hs  <- peekHypos c_ty (n_hypos-1) (p_hypo `plusPtr` (#size PgfTypeHypo))
+      return ((bt,cid,ty):hs)
+
 readProbabilitiesFromFile :: FilePath -> IO (Map.Map String Double)
 readProbabilitiesFromFile fpath = do
   s <- readFile fpath

src/runtime/haskell/PGF2/FFI.hsc

@@ -96,8 +96,9 @@ foreign import ccall "pgf_print_type"
 
 foreign import ccall pgf_print_context :: CSize -> Ptr PgfTypeHypo -> Ptr PgfPrintContext -> CInt -> Ptr PgfMarshaller -> IO (Ptr PgfText)
 
-foreign import ccall "pgf_read_type"
-  pgf_read_type :: Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
+foreign import ccall pgf_read_type :: Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
+
+foreign import ccall pgf_read_context :: Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr CSize -> IO (Ptr PgfTypeHypo)
 
 foreign import ccall pgf_print_start_cat_internal :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO (Ptr PgfText)