msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

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

Browse Source
This commit is contained in:
krangelov
2021-12-23 14:55:26 +01:00
parent 5b5ecc6934
commit f5798350fd
6 changed files with 138 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

39
src/compiler/GF/Command/Abstract.hs
View File

@@ -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

50
src/compiler/GF/Command/Commands.hs
View File

@@ -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

42
src/compiler/GF/Command/Parse.hs
View File

@@ -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)

5
src/compiler/GF/Infra/SIO.hs
View File

@@ -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)

33
src/compiler/GF/Interactive.hs
View File

@@ -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 {

2
src/runtime/haskell/PGF2.hsc
View File

@@ -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"