kicsi.hs 14.8 KB
Newer Older
bbr's avatar
bbr committed
1
2
module Main where

3
import Maybe
bbr's avatar
bbr committed
4
5
import Data.List
import Data.Char
6
import System hiding (getEnv)
bbr's avatar
bbr committed
7
import System.IO
Bernd Brassel's avatar
Bernd Brassel committed
8
import System.Directory (doesFileExist)
9
10
import Control.Monad (unless,when)
import System.FilePath
11
import System.Console.Readline
12

bbr's avatar
bbr committed
13
14
import CurryToHaskell
import SafeCalls
15
16
import MetaProgramming.FlatCurry
import MetaProgramming.FlatCurryGoodies
17
import ShowFlatCurry
bbr's avatar
bbr committed
18
19
import Config
import Names
20

bbr's avatar
bbr committed
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

allFiles = map snd . files
loadedFiles = map snd . filter fst . files

separate s = concat . intersperse s . filter (not . null)

svnrev = filter isDigit "$Rev: 1893 $"

welcome = 
 ["         _               _           _            _"
 ,"        /\\_\\            /\\ \\       /\\ \\          / /\\"
 ,"       / / /  _         \\ \\ \\     /  \\ \\        / /  \\"
 ,"      / / /  /\\_\\       /\\ \\_\\   / /\\ \\ \\      / / /\\ \\__"
 ,"     / / /__/ / /      / /\\/_/  / / /\\ \\ \\    / / /\\ \\___\\"
 ,"    / /\\_____/ /      / / /    / / /  \\ \\_\\   \\ \\ \\ \\/___/"
 ,"   / /\\_______/      / / /    / / /    \\/_/    \\ \\ \\"
 ,"  / / /\\ \\ \\        / / /    / / /         _    \\ \\ \\  The"
 ," / / /  \\ \\ \\   ___/ / /__  / / /________ /_/\\__/ / /  Kiel"
 ,"/ / /    \\ \\ \\ /\\__\\/_/___\\/ / /_________\\\\ \\/___/ /  Curry"
 ,"\\/_/      \\_\\_\\\\/_________/\\/____________/ \\_____\\/  System"
 ,"","Version 0.8"++svnrev,""]
 

compileCall CTC     = "kics -make "
compileCall OrBased = "kics -or -make "

compileModule file choiceMode = system (compileCall choiceMode++file)

Bernd Brassel's avatar
Bernd Brassel committed
49
50
51
52
53
54
55
56
57
58
-------------------------------------
-- read history from file
-------------------------------------

historyFile = "kicsi.hist"

readHistory :: IO ()
readHistory = do 
  exHist <- doesFileExist historyFile
  unless (not exHist) 
bbr's avatar
bbr committed
59
         (readFile historyFile >>=  addLineToHistory 1 . lines)
Bernd Brassel's avatar
Bernd Brassel committed
60
  where
bbr's avatar
bbr committed
61
62
63
64
65
    addLineToHistory _ [] = return ()
    addLineToHistory n (s@(':':_):xs) = addHistory s >> addLineToHistory n xs
    addLineToHistory n (s:xs)         = 
      addHistory ("{-"++show n++"-} "++s) >>
      addLineToHistory (n+1) xs
Bernd Brassel's avatar
Bernd Brassel committed
66

bbr's avatar
bbr committed
67
main = do 
Bernd Brassel's avatar
Bernd Brassel committed
68
  readHistory
bbr's avatar
bbr committed
69
  home <- getEnv "HOME"
bbr's avatar
bbr committed
70
71
  (options,state) <- getOptions
  mapM_ (safe . put 1 options) welcome
Bernd Brassel's avatar
Bernd Brassel committed
72
73
74
75
76
  let files = case filename options of
               "" -> ["Prelude"] 
               fn -> [fn]
      curDir:dirs = libpath options
  load files state options{userlibpath=pathWithSubdirs [curDir]++dirs}
bbr's avatar
bbr committed
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

interactive state opts = do
  mline <- readline (separate "," (loadedFiles state) ++"> ")
  case mline of
    Just line -> addHistory line >>
                 interactiveMenue (words line) state opts
    Nothing   -> return ()

interactiveMenue [] state opts = interactive state opts
interactiveMenue (cmd:cmds) state opts = 
  case map toLower cmd of
    ":load" -> load cmds state opts 
    ":l"    -> load cmds state opts 
    ":add"  -> load (allFiles state++cmds) state opts 
    ":a"    -> load (allFiles state++cmds) state opts 
    ":set"  -> setMenue cmds state opts
    ":reload" -> load (allFiles state) state opts
    ":r"      -> load (allFiles state) state opts
    ":type" -> getType (unwords cmds) state opts
    ":t"    -> getType (unwords cmds) state opts
    ":quit" -> return ()
    ":q"    -> return ()
    ":help" -> help state opts
    ":h"    -> help state opts
    ":?"    -> help state opts
    ":info" -> info cmds (loadedFiles state) state opts
    ":i"    -> info cmds (loadedFiles state) state opts
    ":save" -> writeConfig opts state >> interactive state opts
    ":s"    -> writeConfig opts state >> interactive state opts
    ':':'!':c -> safe (safeSystem False (unwords (c:cmds))) >> interactive state opts
    ':':_   -> putStrLn "unknown command, type :? for help" >> 
               interactive state opts
    _       -> requestExpr state opts (unwords (cmd:cmds))

setMenue [] state opts = do  
  putStrLn "options"
  putStrLn "-------"
  putStrLn $ "search mode:          " ++ (show (pm opts))
115
  putStrLn $ "timing:               " ++ onOff (time state)
116
117
  putStrLn $ "debug:                " ++ onOff (debug opts) 
                                      ++ maybe "" (" -- "++) (debugger opts)
118
  putStrLn $ "evaluation mode:      " ++ evalMode (eval opts)
bbr's avatar
bbr committed
119
  putStrLn $ "verbosity level:      " ++ show (verbosity opts)
bbr's avatar
bbr committed
120
121
122
123
  putStrLn $ "recompilation:        " ++ if force opts then "always (+f)" 
                                                       else "only if older (-f)"  
  putStrLn "\npaths and commands"
  putStrLn "------------------"
bbr's avatar
bbr committed
124
125
  putStrLn   $ "command line options:   " ++ cmdLineArgs state
  putStrLn   $ "run time settings:      " ++ rts state
126
  putStrLn   $ "ghc compiler options:   " ++ ghcOpts opts
bbr's avatar
bbr committed
127
  putStrLn "paths to libraries:   " 
Bernd Brassel's avatar
Bernd Brassel committed
128
129
  let dir:_:_:dirs = libpath opts
  mapM_ putPath (dir:dirs)
bbr's avatar
bbr committed
130
  interactive state opts
bbr's avatar
bbr committed
131
   where
bbr's avatar
bbr committed
132
    putPath p = putStr "                      " >> putStrLn p
bbr's avatar
bbr committed
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149

setMenue (opt:vals) state opts = do
  case map (map toLower) (opt:vals) of
   ["or"] -> load (allFiles state) state opts{cm=OrBased}
   ["ctc"] -> load (allFiles state) state opts{cm=CTC}
   ["depth","first"] -> interactive state (newSm opts DF)
   ["df"] -> interactive state (newSm opts DF)
   ["breadth","first"] -> interactive state (newSm opts BF)
   ["bf"] -> interactive state (newSm opts BF)
   ["all","solutions"] -> interactive state (newPm opts (All DF))
   ["all"] -> interactive state (newPm opts (All DF))
   ["first","solution"] -> interactive state (newPm opts (First DF))
   ["first"]            -> interactive state (newPm opts (First DF))
   ["interactive"] -> interactive state (newPm opts (Interactive DF))
   ["i"] -> interactive state (newPm opts (Interactive DF))
   ["search","tree"] -> interactive state opts{pm=ST}
   ["st"] -> interactive state opts{pm=ST}
bbr's avatar
bbr committed
150
151
   ["path",path] -> let (thisDir:oldPath)=userlibpath opts
     in interactive state opts{userlibpath=thisDir:path:oldPath}
bbr's avatar
bbr committed
152
   ["verbosity",i] | all isDigit i -> interactive state opts{verbosity=read i}
bbr's avatar
bbr committed
153
   ["v",i] | all isDigit i -> interactive state opts{verbosity=read i}
bbr's avatar
bbr committed
154
   ("command":_) -> interactive state{cmdLineArgs=unwords vals} opts
155
   ("cmd":_) -> interactive state{cmdLineArgs=unwords vals} opts
bbr's avatar
bbr committed
156
   ("rts":_) -> interactive state{rts=' ':unwords vals++" "} opts
157
158
159
160
   ("rts+":_)-> interactive state{rts=rts state++' ':unwords vals++" "} opts
   ("ghc":_) -> interactive state opts{ghcOpts=' ':unwords vals++" "}
   ("ghc+":_) -> interactive state 
                   opts{ghcOpts=ghcOpts opts++' ':unwords vals++" "}
161
162
   ["debugger",debugTool] -> interactive state 
                     opts{debugger=Just (head vals)}
bbr's avatar
bbr committed
163
164
   ['+':'+':setting] -> longSetting True  state opts setting
   ['-':'-':setting] -> longSetting False state opts setting
bbr's avatar
bbr committed
165
166
   (('+':s):sets) -> shortSettings True  state opts (concat (s:sets))
   (('-':s):sets) -> shortSettings False state opts (concat (s:sets))
bbr's avatar
bbr committed
167
168
   _ -> putStrLn ("invalid setting. Example \":set breadth first\" to " ++
                  "set search strategy to breadth first") >> 
bbr's avatar
bbr committed
169
        interactive state opts
bbr's avatar
bbr committed
170

bbr's avatar
bbr committed
171
172
longSetting flag state opts "debug"     = 
  interactive state opts{debug=flag,doNotUseInterface=flag}
173
174
175
176
177
178
longSetting flag state opts "time"      = do
  warn state{time=flag} opts 
  interactive state{time=flag} opts
longSetting flag state opts "eval"      = do
  warn state opts{eval=flag}
  interactive state opts{eval=flag}
bbr's avatar
bbr committed
179
180
181
longSetting flag state opts "make"      = interactive state opts{make=flag}
longSetting flag state opts "force"     = interactive state opts{force=flag}
longSetting _    state opts _           = putStrLn "invalid setting." >> interactive state opts
bbr's avatar
bbr committed
182

183
184
185
186
187
shortSettings _    state opts [] = do
  warn state opts
  interactive state opts
shortSettings flag state opts ('t':settings) = do
  putStrLn $ "setting time " ++ onOff flag 
bbr's avatar
bbr committed
188
189
190
191
192
  shortSettings flag state{time=flag} opts settings 
shortSettings flag state opts ('-':settings) = 
  shortSettings False state opts settings 
shortSettings flag state opts ('+':settings) = 
  shortSettings True  state opts settings 
193
194
195
shortSettings flag state opts (c:settings) = do
    o <- newOpts c
    shortSettings flag state o settings 
bbr's avatar
bbr committed
196
  where
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
    newOpts 'd' = putStrLn ("setting debbug " ++ onOff flag) >>
                  return opts{debug=flag,doNotUseInterface=flag}
    newOpts 'e' = putStrLn ("setting evaluation mode to " ++ evalMode flag) >>
                  return opts{eval=flag}
    newOpts 'm' = putStrLn ("setting make " ++ onOff flag) >>
                  return opts{make=flag}
    newOpts 'f' = putStrLn ("setting recompilation to " ++ forceMode flag) >>
                  return opts{force=flag}
    newOpts c   = putStrLn ("unknown short option: "++show c) >>
                  putStrLn ("  (long options are set with \"++\" and \"--\", e.g.,\ 
                            \ \":set ++time\"") >>
                  return opts

onOff True  = "on"
onOff False = "off" 
evalMode True  = "interpreted (+e)"
evalMode False = "compiled (-e)"
forceMode True  = "always (+f)"
forceMode False = "only if older (-f)"

warn state opts = 
  when (time state && eval opts) 
       (putStrLn "warning: for benchmarking you should use +t together with -e")

bbr's avatar
bbr committed
221

bbr's avatar
bbr committed
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
help state opts = do
  mapM_ putStrLn  
    [":load              load a (number of) file(s)"
    ,":set <option>      set a KiCSi <option>"
    ,":set               see current KiCSi options"
    ,":reload            reload current files" 
    ,":type <expression> show type of <expression>"
    ,":quit              leave KiCSi"
    ,":help              this message"
    ,":!                 system command"]
  interactive state opts
  
info _ [] state opts = interactive state opts
info x (f:fs) state opts = do 
  safe (do 
	p <- safeReadFlat opts (f++".fint")
	safeIO (putStrLn (showFlatProg p))
        safeIO (putStrLn ""))
  info x fs state opts

newSm opts@Opts{pm=All _} x = opts{pm=All x}
newSm opts@Opts{pm=Interactive _} x = opts{pm=Interactive x}
newSm opts@Opts{pm=ST} x = opts{pm=Interactive x}

newPm opts@Opts{pm=ST} x = opts{pm=x}
newPm opts@Opts{pm=All x}   (Interactive _) = opts{pm=Interactive x}
newPm opts@Opts{pm=Interactive x} (All _)   = opts{pm=All x}
newPm opts@Opts{pm=All x}         (First _) = opts{pm=First x}
newPm opts@Opts{pm=Interactive x} (First _) = opts{pm=First x}
newPm opts@Opts{pm=First x} (Interactive _) = opts{pm=Interactive x}
newPm opts@Opts{pm=First x} (All _)         = opts{pm=All x}
newPm opts _ = opts

getType expr state opts = do 
    t <- (safe $ do 
            genReqModule (loadedFiles state) expr
            cymake (opts{filename=reqModuleName})
259
            p <- safeIO (readFlatCurry reqModuleFile)
Bernd Brassel's avatar
Bernd Brassel committed
260
            let (f:_) = filter ((==mainExpr) . snd . funcName) (progFuncs p)
bbr's avatar
bbr committed
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
            return (funcType f))
    maybe (return ()) (putStrLn . showCurryType snd False) t
    interactive state opts
               
load [] state opts = interactive state opts
load xs state opts = do
  done <- startCompilations opts{executable=False} fs
  interactive state{files=map (isLoaded done) (nub fs)} opts
  where
    fs = map baseName xs
    isLoaded done f = (elem f done,f)

                  
toMode _ ["or"]  = OrBased
toMode _ ["ctc"] = CTC
toMode m _ = m

Bernd Brassel's avatar
Bernd Brassel committed
278
279
280
mainExpr = "expression"


bbr's avatar
bbr committed
281
requestExpr state opts line = do 
282
  safe $ do
bbr's avatar
bbr committed
283
    let ls = loadedFiles state
Bernd Brassel's avatar
Bernd Brassel committed
284
        mainMod = if null ls then "Prelude" else head ls
285
286
287
288
    --safeSystem (verbosity opts >= 5) 
    --           ("rm -f request Request.fcy "++reqMod ++".o ") 
    requestFile <- genReqModule (loadedFiles state) line
    let compileOpts = (opts{executable=True,filename=requestFile,
Bernd Brassel's avatar
Bernd Brassel committed
289
290
                            mainFunc=mainExpr,
                            mainModule = mainMod,
291
292
                            make=False})  
    startCompilation compileOpts
bbr's avatar
bbr committed
293
    let call = timing state (requestCall state opts)
bbr's avatar
bbr committed
294
295
    when (not (eval opts))
         (safeSystem (verbosity opts >= 3) 
296
297
                     (ghcCall opts{target=inKicsSubdir "request",
                                   filename=inKicsSubdir "Main.hs"}))
bbr's avatar
bbr committed
298
299
    when (verbosity opts >= 2 || not (eval opts))
         (put 1 opts ("starting evaluation of "++line))
bbr's avatar
bbr committed
300
    safeSystem (verbosity opts >= 3) call
301
302
303
    when (debug opts) $ do
      if debugger opts == Nothing 
       then do
bbr's avatar
bbr committed
304
         safeSystem (verbosity opts >= 5) (stricthsCall compileOpts{make=True})
bbr's avatar
bbr committed
305
         safeSystem (verbosity opts >= 5) 
306
307
                    (ghcCall opts{make=True,ghcOpts=ghcOpts opts++" -O2 ", 
                                  filename="StrictRequest"})
bbr's avatar
bbr committed
308
         safeSystem (verbosity opts >= 5) 
309
                    (ghcCall opts{make=False,eval=True, 
Bernd Brassel's avatar
Bernd Brassel committed
310
                                  ghcOpts=ghcOpts opts++" -e "++mainExpr++" ",
311
312
                                  filename="StrictRequest"})
       else do
313
314
315
         safeSystem (verbosity opts >= 5) 
                    (mkStrictCall compileOpts{filename=inKicsSubdir reqModuleName,
                                              make=True})
Bernd Brassel's avatar
Bernd Brassel committed
316
         genDebugModule opts{mainModule=mainMod} (loadedFiles state) line
317
         safeSystem (verbosity opts >= 5) 
Bernd Brassel's avatar
Bernd Brassel committed
318
319
                    (ghcCall opts{target=inKicsSubdir "debug",debug=False,
                                  make=True,ghcOpts=ghcOpts opts++" -O2 ", 
Bernd Brassel's avatar
Bernd Brassel committed
320
                                  filename=inKicsSubdir debugModuleName})
Bernd Brassel's avatar
Bernd Brassel committed
321
322
         safeSystem (verbosity opts >= 5) 
                    (inKicsSubdir "debug")
323
 
bbr's avatar
bbr committed
324
325
  interactive state opts

Bernd Brassel's avatar
Bernd Brassel committed
326
327
328
329
-- in ghc 6.10 we cannot combine make with "-e"
-- In order to avoid link errors we somehow need 
-- to start make before calling "-e", but it is not yet clear
-- how to avoid generating a binary.
bbr's avatar
bbr committed
330
requestCall state opts@Opts{eval=True} = 
Bernd Brassel's avatar
Bernd Brassel committed
331
  ghcCall opts{make=False,
332
333
334
               ghcOpts=ghcOpts opts++ " +RTS "++ rts state ++ " -RTS -e main ",
               filename=inKicsSubdir "Main.hs"}
requestCall state _ = (inKicsSubdir "request"++" "++cmdLineArgs state++" +RTS "++rts state)
bbr's avatar
bbr committed
335
336

reqModuleName = "Request"
337
reqModuleFile = replaceExtension (inKicsSubdir reqModuleName) ".fcy"
bbr's avatar
bbr committed
338
339

genReqModule fs line = 
Bernd Brassel's avatar
Bernd Brassel committed
340
341
  safeIO (writeKicsFile False (replaceExtension reqModuleName ".curry")
                              (imports fs++"\n\n"++mainExpr++" = "++ line))
bbr's avatar
bbr committed
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357

timing (State{time=True}) s = "time "++s
timing _ s = s


unqualMain s = examine (groupBy (\x y->isExtAlpha x && isExtAlpha y) s)
  where
    examine (_:".":"main":xs) = examine xs
    examine ("main":_) = True
    examine (_:xs) = examine xs
    examine [] = False

isExtAlpha '_' = True
isExtAlpha '\'' = True
isExtAlpha c = isDigit c || isAlpha c

Bernd Brassel's avatar
Bernd Brassel committed
358
reqMod = modName reqModuleName
bbr's avatar
bbr committed
359

Bernd Brassel's avatar
Bernd Brassel committed
360
imports :: [String] -> String
bbr's avatar
bbr committed
361
imports = concatMap ("\nimport "++) 
bbr's avatar
bbr committed
362

Bernd Brassel's avatar
Bernd Brassel committed
363
364
365
366
367
368
369
370
------------------------------
-- triggering the debug tool
------------------------------

debugModuleName = "debug.hs"
genDebugModule Opts{debugger=Just tool,mainModule=mod} fs line = do
  let modName    = debugModuleName
      modImports = imports $ "Debugger.DebugMonad":
Bernd Brassel's avatar
Bernd Brassel committed
371
                          ("Debugger.Tools."++tool++"."++"Monad"):
Bernd Brassel's avatar
Bernd Brassel committed
372
373
374
                          map mkStrictName ((reqModuleName++" as S"):fs)
      modCont = modImports ++
        "\n\nmain = do\n\
375
        \  run (S.strict_"++mainExpr++") \""++mod++"\""
Bernd Brassel's avatar
Bernd Brassel committed
376
377
  --safeIO $ putStrLn modName
  --safeIO $ putStrLn modCont
Bernd Brassel's avatar
Bernd Brassel committed
378
  safeIO (writeKicsFile False modName modCont)
Bernd Brassel's avatar
Bernd Brassel committed
379
380
           
         
bbr's avatar
bbr committed
381