From f5798350fd2ebb6850f11e1c82c4ef7c0699fb6d Mon Sep 17 00:00:00 2001 From: krangelov Date: Thu, 23 Dec 2021 14:55:26 +0100 Subject: [PATCH] commands "create fun" & "drop fun" in the shell --- src/compiler/GF/Command/Abstract.hs | 39 +++++++++++++--------- src/compiler/GF/Command/Commands.hs | 50 +++++++++++++++++++++++------ src/compiler/GF/Command/Parse.hs | 42 +++++++++++++++++++++--- src/compiler/GF/Infra/SIO.hs | 5 +++ src/compiler/GF/Interactive.hs | 33 +++++++++++++++++-- src/runtime/haskell/PGF2.hsc | 2 +- 6 files changed, 138 insertions(+), 33 deletions(-) diff --git a/src/compiler/GF/Command/Abstract.hs b/src/compiler/GF/Command/Abstract.hs index e85d0805c..32e0eb932 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,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 diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index d0b9bea93..c06df6865 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/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 `." + ], + 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 diff --git a/src/compiler/GF/Command/Parse.hs b/src/compiler/GF/Command/Parse.hs index 9ead12e7e..b632248ab 100644 --- a/src/compiler/GF/Command/Parse.hs +++ b/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) diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index 1c1829428..1ff6827c7 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/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) diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 881592a0b..65b63eae1 100644 --- a/src/compiler/GF/Interactive.hs +++ 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 { diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index c07637291..8672526de 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/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"