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
+  | OFlag Ident Literal
-  deriving (Eq,Ord,Show)
-
-data Value
-  = VId  Ident
-  | VInt Int
-  | VStr String
   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
+  case [v | OFlag f (LInt v) <- opts, f == flag] of
-    (v:_) -> fn v
+    (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
+    LInt v -> show v
-    VId  v -> v
+    LFlt v -> show v
-    VInt 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",
+       "The command has one argument which is either a function, an expression or",
-       "a category defined in the abstract syntax of the current grammar. ",
+       "a category defined in the abstract syntax of the current grammar.",
-       "If the argument is a function then ?its type is printed out.",
+       "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",
+       "If a whole expression is given, then it prints the expression with refined",
-       "metavariables and the type of the expression."
+       "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 (OOpt  op)          | Just (Left  f) <- treeOp pgf op = f
-     app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f x
+     app (OFlag op (LStr x)) | Just (Right f) <- treeOp pgf op = f x
-     app _                                                    = id
+     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)

src/compiler/GF/Infra/SIO.hs

@@ -13,6 +13,7 @@ module GF.Infra.SIO(
        -- ** Specific to GF
        importGrammar,importSource,
        putStrLnFlush,runInterruptibly,lazySIO,
+       modifyPGF, checkoutPGF,
        -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
        -- | If the environment variable GF_RESTRICTED is defined, these
        -- operations will fail. Otherwise, they will be executed normally.
@@ -39,6 +40,7 @@ import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
 import qualified GF.System.Signal as IO(runInterruptibly)
 import qualified GF.Command.Importing as GF(importGrammar, importSource)
 import qualified Control.Monad.Fail as Fail
+import qualified PGF2.Transactions as PGFT
 import Control.Exception
 
 -- * The SIO monad
@@ -132,3 +134,6 @@ lazySIO              = lift1   lazyIO
 
 importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
 importSource      opts files = lift0 $ GF.importSource      opts files
+
+modifyPGF   gr t = lift0 (PGFT.modifyPGF gr t)
+checkoutPGF gr b = lift0 (PGFT.checkoutPGF gr b)

src/compiler/GF/Interactive.hs

@@ -11,7 +11,7 @@ import GF.Command.SourceCommands
 import GF.Command.CommandInfo
 import GF.Command.Help(helpCommand)
 import GF.Command.Abstract
-import GF.Command.Parse(readCommandLine,pCommand)
+import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
 import GF.Data.Operations (Err(..))
 import GF.Data.Utilities(whenM,repeatM)
 import GF.Grammar hiding (Ident,isPrefixOf)
@@ -21,12 +21,13 @@ import GF.Infra.Option
 import qualified System.Console.Haskeline as Haskeline
 
 import PGF2
+import PGF2.Transactions hiding (modifyPGF,checkoutPGF)
 
 import Data.Char
 import Data.List(isPrefixOf)
 import qualified Data.Map as Map
 import qualified Text.ParserCombinators.ReadP as RP
-import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
+import System.Directory(getAppUserDataDirectory)
 import Control.Exception(SomeException,fromException,evaluate,try)
 import Control.Monad.State hiding (void)
 import qualified GF.System.Signal as IO(runInterruptibly)
@@ -124,11 +125,21 @@ execute1' s0 =
          "!" :ws  -> system_command ws
          "eh":ws  -> execute_history ws
          "i" :ws  -> do import_ ws; continue
+         (w  :ws) | w == "c" || w == "d" -> do
+                        case readTransactionCommand s0 of
+                          Just cmd -> do checkout
+                                         mb_pgf <- getPGF
+                                         case mb_pgf of
+                                           Just pgf -> transactionCommand cmd pgf
+                                           Nothing  -> fail "Import a grammar before using this command"
+                          Nothing  -> putStrLnE $ "command not parsed: "++s0
+                        continue
       -- other special commands, working on GFEnv
          "dc":ws  -> define_command ws
          "dt":ws  -> define_tree ws
       -- ordinary commands
          _        -> do env <- gets commandenv
+                        checkout
                         interpretCommandLine env s0
                         continue
   where
@@ -136,6 +147,13 @@ execute1' s0 =
     continue = return True
     stop = return False
 
+    checkout = do
+      mb_pgf <- gets multigrammar
+      case mb_pgf of
+        Just pgf -> do mb_pgf <- lift $ checkoutPGF pgf "master"
+                       modify $ \gfenv -> gfenv{pgfenv = (fst (pgfenv gfenv),mb_pgf)}
+        Nothing  -> return ()
+
     interruptible :: ShellM Bool -> ShellM Bool
     interruptible act =
       do gfenv <- get
@@ -211,6 +229,17 @@ import_ args =
          importInEnv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
        Bad err -> putStrLnE $ "Command parse error: " ++ err
 
+transactionCommand :: TransactionCommand -> PGF -> ShellM ()
+transactionCommand (CreateFun opts f ty) pgf = do
+  let prob = realToFrac (valFltOpts "prob" (1/0) opts)
+  case checkType pgf ty of
+    Left msg -> putStrLnE msg
+    Right ty -> do lift $ modifyPGF pgf (createFunction f ty 0 [] prob)
+                   return ()
+transactionCommand (DropFun opts f) pgf = do
+  lift $ modifyPGF pgf (dropFunction f)
+  return ()
+
 -- | Commands that work on 'GFEnv'
 moreCommands = [
   ("e",  emptyCommandInfo {

src/runtime/haskell/PGF2.hsc

@@ -405,7 +405,7 @@ inferExpr p e =
 -- | Check whether a type is consistent with the abstract
 -- syntax of the grammar.
 checkType :: PGF -> Type -> Either String Type
-checkType = error "TODO: checkType"
+checkType pgf ty = Right ty
   
 compute :: PGF -> Expr -> Expr
 compute = error "TODO: compute"