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
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
module GFI (mainGFI) where
import GF.Command.Interpreter
import GF.Command.Importing
import GF.Command.Commands
import GF.Command.Abstract
import GF.Command.Parse
import GF.Data.ErrM
import GF.Grammar.API -- for cc command
import GF.Infra.UseIO
import GF.Infra.Option
import GF.System.Readline
import PGF
import PGF.Data
import PGF.Macros
import Data.Char
import Data.List(isPrefixOf)
import qualified Data.Map as Map
import qualified Text.ParserCombinators.ReadP as RP
import System.Cmd
import System.CPUTime
import Control.Exception
import Data.Version
import Paths_gf
mainGFI :: Options -> [FilePath] -> IO ()
mainGFI opts files = do
putStrLn welcome
gfenv <- importInEnv emptyGFEnv opts files
loop opts gfenv
return ()
loop :: Options -> GFEnv -> IO GFEnv
loop opts gfenv0 = do
let env = commandenv gfenv0
let sgr = sourcegrammar gfenv0
setCompletionFunction (Just (wordCompletion (commandenv gfenv0)))
s <- fetchCommand (prompt env)
let gfenv = gfenv0 {history = s : history gfenv0}
let loopNewCPU gfenv' = do cpu' <- getCPUTime
putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
loop opts $ gfenv' {cputime = cpu'}
case words s of
-- special commands, requiring source grammar in env
"!":ws -> do
system $ unwords ws
loopNewCPU gfenv
"cc":ws -> do
-- FIXME: add options parsing for cc arguments
let (style,term) = (TermPrintDefault, ws)
case pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr of ---- make pipable
Ok x -> putStrLn (showTerm style x)
Bad s -> putStrLn s
loopNewCPU gfenv
"i":args -> do
gfenv' <- case parseOptions args of
Ok (opts',files) -> importInEnv gfenv (addOptions opts opts') files
Bad err -> do putStrLn $ "Command parse error: " ++ err
return gfenv
loopNewCPU gfenv'
-- other special commands, working on GFEnv
"e":_ -> loopNewCPU $ gfenv {
commandenv=env{multigrammar=emptyPGF}, sourcegrammar = emptyGrammar
}
"ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv
"q":_ -> putStrLn "See you." >> return gfenv
-- ordinary commands, working on CommandEnv
_ -> do
interpretCommandLine env s
loopNewCPU gfenv
importInEnv :: GFEnv -> Options -> [FilePath] -> IO GFEnv
importInEnv gfenv opts files
| flag optRetainResource opts =
do src <- importSource (sourcegrammar gfenv) opts files
return $ gfenv {sourcegrammar = src}
| otherwise =
do let opts' = addOptions (setOptimization OptCSE False) opts
pgf0 = multigrammar (commandenv gfenv)
pgf1 <- importGrammar pgf0 opts' files
putStrLnFlush $ unwords $ "\nLanguages:" : languages pgf1
return $ gfenv { commandenv = mkCommandEnv pgf1 }
welcome = unlines [
" ",
" * * * ",
" * * ",
" * * ",
" * ",
" * ",
" * * * * * * * ",
" * * * ",
" * * * * * * ",
" * * * ",
" * * * ",
" ",
"This is GF version "++showVersion version++". ",
"Some things may work. "
]
prompt env = absname ++ "> " where
absname = case abstractName (multigrammar env) of
"_" -> "" --- created by new Ident handling 22/5/2008
n -> n
data GFEnv = GFEnv {
sourcegrammar :: Grammar, -- gfo grammar -retain
commandenv :: CommandEnv,
history :: [String],
cputime :: Integer
}
emptyGFEnv :: GFEnv
emptyGFEnv = GFEnv emptyGrammar (mkCommandEnv emptyPGF) [] 0
wordCompletion cmdEnv line prefix p =
case wc_type (take p line) of
CmplCmd pref
-> ret ' ' [name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
CmplStr (Just (Command _ opts _)) s
-> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optCat opts)))
case mb_state0 of
Right state0 -> let ws = words (take (length s - length prefix) s)
state = foldl nextState state0 ws
compls = getCompletions state prefix
in ret ' ' (Map.keys compls)
Left _ -> ret ' ' []
CmplOpt (Just (Command n _ _)) pref
-> case Map.lookup n (commands cmdEnv) of
Just inf -> do let flg_compls = ['-':flg | flg <- flags inf, isPrefixOf pref flg]
opt_compls = ['-':opt | opt <- options inf, isPrefixOf pref opt]
ret (if null flg_compls then ' ' else '=')
(flg_compls++opt_compls)
Nothing -> ret ' ' []
CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i
-> filenameCompletionFunction prefix
CmplIdent _ pref
-> do mb_abs <- try (evaluate (abstract pgf))
case mb_abs of
Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name]
Left _ -> ret ' ' []
_ -> ret ' ' []
where
pgf = multigrammar cmdEnv
optLang opts = valIdOpts "lang" (head (languages pgf)) opts
optCat opts = valIdOpts "cat" (lookStartCat pgf) opts
ret c [x] = return [x++[c]]
ret _ xs = return xs
data CompletionType
= CmplCmd Ident
| CmplStr (Maybe Command) String
| CmplOpt (Maybe Command) Ident
| CmplIdent (Maybe Command) Ident
deriving Show
wc_type :: String -> CompletionType
wc_type = cmd_name
where
cmd_name cs =
let cs1 = dropWhile isSpace cs
in go cs1 cs1
where
go x [] = CmplCmd x
go x (c:cs)
| isIdent c = go x cs
| otherwise = cmd x cs
cmd x [] = ret CmplIdent x "" 0
cmd _ ('|':cs) = cmd_name cs
cmd _ (';':cs) = cmd_name cs
cmd x ('"':cs) = str x cs cs
cmd x ('-':cs) = option x cs cs
cmd x (c :cs)
| isIdent c = ident x (c:cs) cs
| otherwise = cmd x cs
option x y [] = ret CmplOpt x y 1
option x y (c:cs)
| isIdent c = option x y cs
| otherwise = cmd x cs
ident x y [] = ret CmplIdent x y 0
ident x y (c:cs)
| isIdent c = ident x y cs
| otherwise = cmd x cs
str x y [] = ret CmplStr x y 1
str x y ('\"':cs) = cmd x cs
str x y ('\\':c:cs) = str x y cs
str x y (c:cs) = str x y cs
ret f x y d = f cmd y
where
x1 = take (length x - length y - d) x
x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=') x1
cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
[x] -> Just x
_ -> Nothing
isIdent c = c == '_' || c == '\'' || isAlphaNum c
|
