1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
module GF.Command.Interpreter (
interpretCommandLine
) 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
interpretCommandLine :: MultiGrammar -> String -> IO ()
interpretCommandLine gr line = case (pCommandLine (myLexer line)) of
Ok CEmpty -> return ()
Ok (CLine pipes) -> mapM_ interPipe pipes
_ -> putStrLn "command not parsed"
where
interPipe (PComm cs) = do
(_,s) <- intercs ([],"") cs
putStrLn s
intercs treess [] = return treess
intercs (trees,_) (c:cs) = do
treess2 <- interc trees c
intercs treess2 cs
interc = interpret gr
-- return the trees to be sent in pipe, and the output possibly printed
interpret :: MultiGrammar -> [Tree] -> Command -> IO CommandOutput
interpret mgr trees0 comm = case lookCommand co commands of
Just info -> do
checkOpts info
tss@(_,s) <- exec info trees
optTrace s
return tss
_ -> do
putStrLn $ "command " ++ co ++ " not interpreted"
return ([],[])
where
optTrace = if isOpt "tr" opts then putStrLn else const (return ())
(co,opts,trees) = getCommand comm trees0
commands = allCommands mgr opts
checkOpts info =
case
[o | OOpt (Ident o) <- opts, notElem o (options info)] ++
[o | OFlag (Ident o) _ <- opts, notElem o (flags info)]
of
[] -> return ()
[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
Comm (Ident c) opts (ATree t) -> (getOp c,opts,[tree2exp t]) -- ignore piped
CNoarg (Ident c) opts -> (getOp c,opts,ts) -- use piped
where
-- abbreviation convention from gf
getOp s = case break (=='_') s of
(a:_,_:b:_) -> [a,b] -- axx_byy --> ab
_ -> case s of
[a,b] -> s -- ab --> ab
a:_ -> [a] -- axx --> a
|
