diff --git a/src/compiler/GF/Command/Abstract.hs b/src/compiler/GF/Command/Abstract.hs index 860c19610..ebf6bc29b 100644 --- a/src/compiler/GF/Command/Abstract.hs +++ b/src/compiler/GF/Command/Abstract.hs @@ -16,8 +16,12 @@ data Command data TransactionCommand = CreateFun [Option] Fun Type | CreateCat [Option] Cat [Hypo] + | CreateLin [Option] Fun Term + | CreateLincat [Option] Cat Term | DropFun [Option] Fun | DropCat [Option] Cat + | DropLin [Option] Fun + | DropLincat [Option] Cat deriving Show data Option diff --git a/src/compiler/GF/Command/Parse.hs b/src/compiler/GF/Command/Parse.hs index 6a6972c8e..31cb13abf 100644 --- a/src/compiler/GF/Command/Parse.hs +++ b/src/compiler/GF/Command/Parse.hs @@ -1,7 +1,9 @@ module GF.Command.Parse(readCommandLine, readTransactionCommand, pCommand) where import PGF(pExpr,pIdent) -import PGF2(readType,readContext) +import PGF2(BindType(..),readType,readContext) +import GF.Infra.Ident(identS) +import GF.Grammar.Grammar(Term(Abs)) import GF.Grammar.Parser(runPartial,pTerm) import GF.Command.Abstract @@ -73,6 +75,33 @@ pTransactionCommand = do | take 1 cmd == "d" -> do c <- pIdent return (DropCat opts c) + "lin" | take 1 cmd == "c" -> do + f <- pIdent + skipSpaces + args <- sepBy pIdent skipSpaces + skipSpaces + char '=' + skipSpaces + t <- readS_to_P (\s -> case runPartial pTerm s of + Right (s,t) -> [(t,s)] + _ -> []) + return (CreateLin opts f (foldr (Abs Explicit . identS) t args)) + | take 1 cmd == "d" -> do + f <- pIdent + return (DropLin opts f) + "lincat" + | take 1 cmd == "c" -> do + f <- pIdent + skipSpaces + char '=' + skipSpaces + t <- readS_to_P (\s -> case runPartial pTerm s of + Right (s,t) -> [(t,s)] + _ -> []) + return (CreateLincat opts f t) + | take 1 cmd == "d" -> do + f <- pIdent + return (DropLincat opts f) _ -> pfail pOption = do diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 25c681c83..046111090 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -242,12 +242,45 @@ transactionCommand (CreateCat opts c ctxt) pgf = do Left msg -> putStrLnE msg Right ty -> do lift $ modifyPGF pgf (createCategory c ctxt prob) return () +transactionCommand (CreateLin opts f t) pgf = do + lang <- optLang pgf opts + lift $ modifyPGF pgf (alterConcrete lang (createLin f [])) + return () +transactionCommand (CreateLincat opts c t) pgf = do + lang <- optLang pgf opts + lift $ modifyPGF pgf (alterConcrete lang (createLincat c [] [] [])) + 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 () +transactionCommand (DropLin opts f) pgf = do + lang <- optLang pgf opts + lift $ modifyPGF pgf (alterConcrete lang (dropLin f)) + return () +transactionCommand (DropLincat opts c) pgf = do + lang <- optLang pgf opts + lift $ modifyPGF pgf (alterConcrete lang (dropLincat c)) + return () + +optLang pgf opts = + case Map.keys (languages pgf) of + [lang] -> completeLang (valStrOpts "lang" lang opts) + _ -> case valStrOpts "lang" "" opts of + "" -> fail "Specify a language to change" + lang -> completeLang lang + where + langs = languages pgf + + completeLang la + | Map.member la langs = return la + | Map.member la' langs = return la' + | otherwise = fail "Unknown language" + where + la' = abstractName pgf ++ la + -- | Commands that work on 'GFEnv' moreCommands = [