diff --git a/src/compiler/GF/Command/Abstract.hs b/src/compiler/GF/Command/Abstract.hs index 32e0eb932..860c19610 100644 --- a/src/compiler/GF/Command/Abstract.hs +++ b/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 diff --git a/src/compiler/GF/Command/Parse.hs b/src/compiler/GF/Command/Parse.hs index b632248ab..6a6972c8e 100644 --- a/src/compiler/GF/Command/Parse.hs +++ b/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 diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 65b63eae1..25c681c83 100644 --- a/src/compiler/GF/Interactive.hs +++ b/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 = [ diff --git a/src/runtime/c/pgf/expr.cxx b/src/runtime/c/pgf/expr.cxx index 468bb5bac..99f5c78a6 100644 --- a/src/runtime/c/pgf/expr.cxx +++ b/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); diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h index edd093446..782822a43 100644 --- a/src/runtime/c/pgf/expr.h +++ b/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(); diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index b15c35e5c..1d128f871 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/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) { diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index c7e797e8d..b43439527 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/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 diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 8672526de..a25c23eb4 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/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 diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 0ec598a8b..b6a563754 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/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)