forked from GitHub/gf-core
factored out commands from interpreter in gfcc
This commit is contained in:
aarne
127
src/GF/Command/Commands.hs
Normal file
127
src/GF/Command/Commands.hs
Normal file
@@ -0,0 +1,127 @@
|
||||
module GF.Command.Commands (
|
||||
allCommands,
|
||||
lookCommand,
|
||||
exec,
|
||||
isOpt,
|
||||
options,
|
||||
flags,
|
||||
CommandOutput
|
||||
) where
|
||||
|
||||
import GF.Command.AbsGFShell hiding (Tree)
|
||||
import GF.Command.PPrTree
|
||||
import GF.Command.ParGFShell
|
||||
import GF.GFCC.API
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.AbsGFCC ----
|
||||
|
||||
import GF.Command.ErrM ----
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
type CommandOutput = ([Tree],String) ---- errors, etc
|
||||
|
||||
data CommandInfo = CommandInfo {
|
||||
exec :: [Tree] -> IO CommandOutput,
|
||||
synopsis :: String,
|
||||
explanation :: String,
|
||||
longname :: String,
|
||||
options :: [String],
|
||||
flags :: [String]
|
||||
}
|
||||
|
||||
emptyCommandInfo :: CommandInfo
|
||||
emptyCommandInfo = CommandInfo {
|
||||
exec = \ts -> return (ts,[]), ----
|
||||
synopsis = "synopsis",
|
||||
explanation = "explanation",
|
||||
longname = "longname",
|
||||
options = [],
|
||||
flags = []
|
||||
}
|
||||
|
||||
lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo
|
||||
lookCommand = Map.lookup
|
||||
|
||||
commandHelpAll :: MultiGrammar -> [Option] -> String
|
||||
commandHelpAll mgr opts = unlines
|
||||
[commandHelp (isOpt "full" opts) (co,info)
|
||||
| (co,info) <- Map.assocs (allCommands mgr opts)]
|
||||
|
||||
commandHelp :: Bool -> (String,CommandInfo) -> String
|
||||
commandHelp full (co,info) = unlines $ [
|
||||
co ++ ", " ++ longname info,
|
||||
synopsis info] ++ if full then [
|
||||
explanation info,
|
||||
"options: " ++ unwords (options info),
|
||||
"flags: " ++ unwords (flags info)
|
||||
] else []
|
||||
|
||||
valIdOpts :: String -> String -> [Option] -> String
|
||||
valIdOpts flag def opts = case valOpts flag (VId (Ident def)) opts of
|
||||
VId (Ident v) -> v
|
||||
_ -> def
|
||||
|
||||
valIntOpts :: String -> Integer -> [Option] -> Int
|
||||
valIntOpts flag def opts = fromInteger $ case valOpts flag (VInt def) opts of
|
||||
VInt v -> v
|
||||
_ -> def
|
||||
|
||||
valOpts :: String -> Value -> [Option] -> Value
|
||||
valOpts flag def opts = case lookup flag flags of
|
||||
Just v -> v
|
||||
_ -> def
|
||||
where
|
||||
flags = [(f,v) | OFlag (Ident f) v <- opts]
|
||||
|
||||
isOpt :: String -> [Option] -> Bool
|
||||
isOpt o opts = elem o [x | OOpt (Ident x) <- opts]
|
||||
|
||||
|
||||
allCommands :: MultiGrammar -> [Option] -> Map.Map String CommandInfo
|
||||
allCommands mgr opts = Map.fromAscList [
|
||||
("gr", emptyCommandInfo {
|
||||
longname = "generate_random",
|
||||
synopsis = "generates a list of random trees, by default one tree",
|
||||
flags = ["number"],
|
||||
exec = \_ -> do
|
||||
ts <- generateRandom mgr optCat
|
||||
return $ fromTrees $ take optNum ts
|
||||
}),
|
||||
("h", emptyCommandInfo {
|
||||
longname = "help",
|
||||
synopsis = "get description of a command, or a the full list of commands",
|
||||
options = ["full"],
|
||||
exec = \ts -> return ([], case ts of
|
||||
[t] -> let co = (showTree t) in
|
||||
case lookCommand co (allCommands mgr opts) of
|
||||
Just info -> commandHelp True (co,info)
|
||||
_ -> "command not found"
|
||||
_ -> commandHelpAll mgr opts)
|
||||
}),
|
||||
("l", emptyCommandInfo {
|
||||
exec = return . fromStrings . map lin,
|
||||
flags = ["lang"]
|
||||
}),
|
||||
("p", emptyCommandInfo {
|
||||
exec = return . fromTrees . concatMap par . toStrings,
|
||||
flags = ["cat","lang"]
|
||||
})
|
||||
]
|
||||
where
|
||||
lin t = unlines [linearize mgr lang t | lang <- optLangs]
|
||||
par s = concat [parse mgr lang optCat s | lang <- optLangs]
|
||||
|
||||
optLangs = case valIdOpts "lang" "" opts of
|
||||
"" -> languages mgr
|
||||
lang -> [lang]
|
||||
optCat = valIdOpts "cat" (lookAbsFlag gr (cid "startcat")) opts
|
||||
optNum = valIntOpts "number" 1 opts
|
||||
|
||||
gr = gfcc mgr
|
||||
|
||||
fromTrees ts = (ts,unlines (map showTree ts))
|
||||
fromStrings ss = (map tStr ss, unlines ss)
|
||||
toStrings ts = [s | DTr [] (AS s) [] <- ts]
|
||||
tStr s = DTr [] (AS s) []
|
||||
|
||||
@@ -2,6 +2,7 @@ module GF.Command.Interpreter (
|
||||
interpretCommandLine
|
||||
) where
|
||||
|
||||
import GF.Command.Commands
|
||||
import GF.Command.AbsGFShell hiding (Tree)
|
||||
import GF.Command.PPrTree
|
||||
import GF.Command.ParGFShell
|
||||
@@ -52,111 +53,6 @@ interpret mgr trees0 comm = case lookCommand co commands of
|
||||
[o] -> putStrLn $ "option not interpreted: " ++ o
|
||||
os -> putStrLn $ "options not interpreted: " ++ unwords os
|
||||
|
||||
type CommandOutput = ([Tree],String) ---- errors, etc
|
||||
|
||||
data CommandInfo = CommandInfo {
|
||||
exec :: [Tree] -> IO CommandOutput,
|
||||
synopsis :: String,
|
||||
explanation :: String,
|
||||
longname :: String,
|
||||
options :: [String],
|
||||
flags :: [String]
|
||||
}
|
||||
|
||||
emptyCommandInfo :: CommandInfo
|
||||
emptyCommandInfo = CommandInfo {
|
||||
exec = \ts -> return (ts,[]), ----
|
||||
synopsis = "synopsis",
|
||||
explanation = "explanation",
|
||||
longname = "longname",
|
||||
options = [],
|
||||
flags = []
|
||||
}
|
||||
|
||||
lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo
|
||||
lookCommand = Map.lookup
|
||||
|
||||
commandHelpAll :: MultiGrammar -> [Option] -> String
|
||||
commandHelpAll mgr opts = unlines
|
||||
[commandHelp (isOpt "full" opts) (co,info)
|
||||
| (co,info) <- Map.assocs (allCommands mgr opts)]
|
||||
|
||||
commandHelp :: Bool -> (String,CommandInfo) -> String
|
||||
commandHelp full (co,info) = unlines $ [
|
||||
co ++ ", " ++ longname info,
|
||||
synopsis info] ++ if full then [
|
||||
explanation info,
|
||||
"options: " ++ unwords (options info),
|
||||
"flags: " ++ unwords (flags info)
|
||||
] else []
|
||||
|
||||
allCommands :: MultiGrammar -> [Option] -> Map.Map String CommandInfo
|
||||
allCommands mgr opts = Map.fromAscList [
|
||||
("gr", emptyCommandInfo {
|
||||
longname = "generate_random",
|
||||
synopsis = "generates a list of random trees, by default one tree",
|
||||
flags = ["number"],
|
||||
exec = \_ -> do
|
||||
ts <- generateRandom mgr optCat
|
||||
return $ fromTrees $ take optNum ts
|
||||
}),
|
||||
("h", emptyCommandInfo {
|
||||
longname = "help",
|
||||
synopsis = "get description of a command, or a the full list of commands",
|
||||
options = ["full"],
|
||||
exec = \ts -> return ([], case ts of
|
||||
[t] -> let co = (showTree t) in
|
||||
case lookCommand co (allCommands mgr opts) of
|
||||
Just info -> commandHelp True (co,info)
|
||||
_ -> "command not found"
|
||||
_ -> commandHelpAll mgr opts)
|
||||
}),
|
||||
("l", emptyCommandInfo {
|
||||
exec = return . fromStrings . map lin,
|
||||
flags = ["lang"]
|
||||
}),
|
||||
("p", emptyCommandInfo {
|
||||
exec = return . fromTrees . concatMap par . toStrings,
|
||||
flags = ["cat","lang"]
|
||||
})
|
||||
]
|
||||
where
|
||||
lin t = unlines [linearize mgr lang t | lang <- optLangs]
|
||||
par s = concat [parse mgr lang optCat s | lang <- optLangs]
|
||||
|
||||
optLangs = case valIdOpts "lang" "" opts of
|
||||
"" -> languages mgr
|
||||
lang -> [lang]
|
||||
optCat = valIdOpts "cat" (lookAbsFlag gr (cid "startcat")) opts
|
||||
optNum = valIntOpts "number" 1 opts
|
||||
|
||||
gr = gfcc mgr
|
||||
|
||||
fromTrees ts = (ts,unlines (map showTree ts))
|
||||
fromStrings ss = (map tStr ss, unlines ss)
|
||||
toStrings ts = [s | DTr [] (AS s) [] <- ts]
|
||||
tStr s = DTr [] (AS s) []
|
||||
|
||||
valIdOpts :: String -> String -> [Option] -> String
|
||||
valIdOpts flag def opts = case valOpts flag (VId (Ident def)) opts of
|
||||
VId (Ident v) -> v
|
||||
_ -> def
|
||||
|
||||
valIntOpts :: String -> Integer -> [Option] -> Int
|
||||
valIntOpts flag def opts = fromInteger $ case valOpts flag (VInt def) opts of
|
||||
VInt v -> v
|
||||
_ -> def
|
||||
|
||||
valOpts :: String -> Value -> [Option] -> Value
|
||||
valOpts flag def opts = case lookup flag flags of
|
||||
Just v -> v
|
||||
_ -> def
|
||||
where
|
||||
flags = [(f,v) | OFlag (Ident f) v <- opts]
|
||||
|
||||
isOpt :: String -> [Option] -> Bool
|
||||
isOpt o opts = elem o [x | OOpt (Ident x) <- opts]
|
||||
|
||||
-- analyse command parse tree to a uniform datastructure, normalizing comm name
|
||||
getCommand :: Command -> [Tree] -> (String,[Option],[Tree])
|
||||
getCommand co ts = case co of
|
||||
|
||||
Reference in New Issue
Block a user