commands "create fun" & "drop fun" in the shell

src/compiler/GF/Command/Abstract.hs

@@ -1,6 +1,6 @@
-module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Term) where
+module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Literal(..),Term) where
 
-import PGF2(Expr,showExpr)
+import PGF2(Expr,showExpr,Literal(..),Type)
 import GF.Grammar.Grammar(Term)
 
 type Ident = String
@@ -13,15 +13,14 @@ data Command
    = Command Ident [Option] Argument
    deriving Show
 
+data TransactionCommand
+   = CreateFun [Option] Ident Type
+   | DropFun [Option] Ident
+   deriving Show
+
 data Option
   = OOpt Ident
-  | OFlag Ident Value
-  deriving (Eq,Ord,Show)
-
-data Value
-  = VId  Ident
-  | VInt Int
-  | VStr String
+  | OFlag Ident Literal
   deriving (Eq,Ord,Show)
 
 data Argument
@@ -33,9 +32,19 @@ data Argument
 
 valIntOpts :: String -> Int -> [Option] -> Int
 valIntOpts flag def opts =
-  case [v | OFlag f (VInt v) <- opts, f == flag] of
+  case [v | OFlag f (LInt v) <- opts, f == flag] of
+    (v:_) -> fromIntegral v
+    _     -> def
+
+valFltOpts :: String -> Double -> [Option] -> Double
+valFltOpts flag def opts =
+  case [v | OFlag f v <- opts, v <- toFlt v, f == flag] of
     (v:_) -> v
     _     -> def
+  where
+    toFlt (LInt v) = [fromIntegral v]
+    toFlt (LFlt f) = [f]
+    toFlt _        = []
 
 valStrOpts :: String -> String -> [Option] -> String
 valStrOpts flag def opts =
@@ -45,8 +54,8 @@ valStrOpts flag def opts =
 
 maybeIntOpts :: String -> a -> (Int -> a) -> [Option] -> a
 maybeIntOpts flag def fn opts =
-  case [v | OFlag f (VInt v) <- opts, f == flag] of
-    (v:_) -> fn v
+  case [v | OFlag f (LInt v) <- opts, f == flag] of
+    (v:_) -> fn (fromIntegral v)
     _     -> def
 
 maybeStrOpts :: String -> a -> (String -> a) -> [Option] -> a
@@ -59,9 +68,9 @@ listFlags flag opts = [v | OFlag f v <- opts, f == flag]
 
 valueString v =
   case v of
-    VStr v -> v
-    VId  v -> v
-    VInt v -> show v
+    LInt v -> show v
+    LFlt v -> show v
+    LStr v -> v
 
 isOpt :: String -> [Option] -> Bool
 isOpt o opts = elem (OOpt o) opts

src/compiler/GF/Command/Commands.hs

@@ -31,7 +31,6 @@ import GF.Text.Pretty
 import Data.List (sort)
 import Control.Monad(mplus)
 import qualified Control.Monad.Fail as Fail
---import Debug.Trace
 
 
 class (Functor m,Monad m,MonadSIO m) => HasPGF m where getPGF :: m (Maybe PGF)
@@ -649,12 +648,12 @@ pgfCommands = Map.fromList [
      syntax = "ai IDENTIFIER  or  ai EXPR",
      synopsis = "Provides an information about a function, an expression or a category from the abstract syntax",
      explanation = unlines [
-       "The command has one argument which is either function, expression or",
-       "a category defined in the abstract syntax of the current grammar. ",
-       "If the argument is a function then ?its type is printed out.",
+       "The command has one argument which is either a function, an expression or",
+       "a category defined in the abstract syntax of the current grammar.",
+       "If the argument is a function then its type is printed out.",
        "If it is a category then the category definition is printed.",
-       "If a whole expression is given it prints the expression with refined",
-       "metavariables and the type of the expression."
+       "If a whole expression is given, then it prints the expression with refined",
+       "metavariables as well as the type of the expression."
        ],
      exec = needPGF $ \opts arg pgf -> do
        case toExprs arg of
@@ -682,13 +681,44 @@ pgfCommands = Map.fromList [
          _           -> do putStrLn "a single identifier or expression is expected from the command"
                            return void,
      needsTypeCheck = False
+     }),
+  ("c", emptyCommandInfo {
+     longname = "create",
+     syntax = "create fun f = ..; create cat c = ..; create lin c = ..; or create lincat c = ..",
+     synopsis = "Dynamically adds new functions and categories to the current grammar.",
+     explanation = unlines [
+       "After the command you can write fun, data, cat, lin or a lincat definition.",
+       "The syntax is the same as if the definition was in a module. If you want to use",
+       "any operations inside lin and lincat, you should import them",
+       "by using the command `i -resource <file path>`."
+       ],
+     flags = [
+       ("lang","the language to which to add a lin or a lincat"),
+       ("prob","the probability for a new abstract function")
+       ],
+     needsTypeCheck = False
+     }),
+  ("d", emptyCommandInfo {
+     longname = "drop",
+     syntax = "drop fun f; drop cat c; drop lin c; or drop lincat c",
+     synopsis = "Dynamically removes functions and categories from the current grammar.",
+     explanation = unlines [
+       "After the command you must specify whether you want to remove",
+       "fun, data, cat, lin or a lincat definition.",
+       "Note that if you are removing an abstract function or category,",
+       "then all corresponding linearizations will be dropped as well."
+       ],
+     flags = [
+       ("lang","the language from which to remove the lin or the lincat")
+       ],
+     needsTypeCheck = False
      })
   ]
  where
    needPGF exec opts ts = do
      mb_pgf <- getPGF
      case mb_pgf of
-       Just pgf -> liftSIO $ exec opts ts pgf
+       Just pgf -> do liftSIO $ exec opts ts pgf
        _ -> fail "Import a grammar before using this command"
 
    joinPiped (Piped (es1,ms1)) (Piped (es2,ms2)) = Piped (jA es1 es2,ms1+++-ms2)
@@ -815,9 +845,9 @@ pgfCommands = Map.fromList [
 
    -- ps -f -g s returns g (f s)
    treeOps pgf opts s = foldr app s (reverse opts) where
-     app (OOpt  op)         | Just (Left  f) <- treeOp pgf op = f
-     app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f x
-     app _                                                    = id
+     app (OOpt  op)          | Just (Left  f) <- treeOp pgf op = f
+     app (OFlag op (LStr x)) | Just (Right f) <- treeOp pgf op = f x
+     app _                                                     = id
 
 morphoMissing  :: Concr -> [String] -> [String]
 morphoMissing = morphoClassify False

src/compiler/GF/Command/Parse.hs

@@ -1,6 +1,7 @@
-module GF.Command.Parse(readCommandLine, pCommand) where
+module GF.Command.Parse(readCommandLine, readTransactionCommand, pCommand) where
 
 import PGF(pExpr,pIdent)
+import PGF2(readType)
 import GF.Grammar.Parser(runPartial,pTerm)
 import GF.Command.Abstract
 
@@ -32,20 +33,51 @@ pCommand = (do
   char '?'
   skipSpaces
   c <- pSystemCommand
-  return (Command "sp" [OFlag "command" (VStr c)] ANoArg)
+  return (Command "sp" [OFlag "command" (LStr c)] ANoArg)
   )
 
+readTransactionCommand :: String -> Maybe TransactionCommand
+readTransactionCommand s =
+    case [x | (x,cs) <- readP_to_S pTransactionCommand s, all isSpace cs] of
+      [x] -> Just x
+      _   -> Nothing
+
+pTransactionCommand = do
+  skipSpaces
+  cmd <- pIdent
+  skipSpaces
+  opts <- sepBy pOption skipSpaces
+  skipSpaces
+  kwd <- pIdent
+  skipSpaces
+  case kwd of
+    "fun" | take 1 cmd == "c" -> do
+               f <- pIdent
+               skipSpaces
+               char ':'
+               skipSpaces
+               ty <- readS_to_P (\s -> case readType s of
+                                         Just ty -> [(ty,"")]
+                                         Nothing -> [])
+               return (CreateFun opts f ty)
+          | take 1 cmd == "d" -> do
+                f <- pIdent
+                return (DropFun opts f)
+    _     -> pfail
+
 pOption = do
   char '-'
   flg <- pIdent
   option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
 
 pValue = do
-  fmap VInt (readS_to_P reads)
+  fmap LInt (readS_to_P reads)
   <++
-  fmap VStr (readS_to_P reads)
+  fmap LFlt (readS_to_P reads)
   <++
-  fmap VId  pFilename
+  fmap LStr (readS_to_P reads)
+  <++
+  fmap LStr pFilename
 
 pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
   isFileFirst c = not (isSpace c) && not (isDigit c)