/
Main.hs
207 lines (190 loc) · 8.19 KB
/
Main.hs
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
module Main where
import Control.Monad.Reader
import qualified Control.Exception as E
import Data.List
import Data.Time
import System.Directory
import System.FilePath
import System.Environment
import System.Console.GetOpt
import System.Console.Haskeline
import System.Console.Haskeline.History
import Text.Printf
import Exp.Lex
import Exp.Par
import Exp.Print
import Exp.Abs hiding (NoArg)
import Exp.Layout
import Exp.ErrM
import CTT
import Cartesian
import Resolver
import qualified TypeChecker as TC
import qualified Eval as E
type Interpreter a = InputT IO a
-- Flag handling
data Flag = Debug | Batch | Help | Version | Time
deriving (Eq,Show)
options :: [OptDescr Flag]
options = [ Option "d" ["debug"] (NoArg Debug) "run in debugging mode"
, Option "b" ["batch"] (NoArg Batch) "run in batch mode"
, Option "" ["help"] (NoArg Help) "print help"
, Option "-t" ["time"] (NoArg Time) "measure time spent computing"
, Option "" ["version"] (NoArg Version) "print version number" ]
-- Version number, welcome message, usage and prompt strings
version, welcome, usage, prompt :: String
version = "1.0"
welcome = "yacctt, version: " ++ version ++ " (:h for help)\n"
usage = "Usage: yacctt [options] <file.ctt>\nOptions:"
prompt = "> "
lexer :: String -> [Token]
lexer = resolveLayout True . myLexer
showTree :: (Show a, Print a) => a -> IO ()
showTree tree = do
putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree
putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree
-- Used for auto completion
searchFunc :: [String] -> String -> [Completion]
searchFunc ns str = map simpleCompletion $ filter (str `isPrefixOf`) ns
settings :: [String] -> Settings IO
settings ns = Settings
{ historyFile = Nothing
, complete = completeWord Nothing " \t" $ return . searchFunc ns
, autoAddHistory = True }
main :: IO ()
main = do
args <- getArgs
case getOpt Permute options args of
(flags,files,[])
| Help `elem` flags -> putStrLn $ usageInfo usage options
| Version `elem` flags -> putStrLn version
| otherwise -> case files of
[] -> do
putStrLn welcome
runInputT (settings []) (loop flags [] [] TC.verboseEnv)
[f] -> do
putStrLn welcome
putStrLn $ "Loading " ++ show f
initLoop flags f emptyHistory
_ -> putStrLn $ "Input error: zero or one file expected\n\n" ++
usageInfo usage options
(_,_,errs) -> putStrLn $ "Input error: " ++ concat errs ++ "\n" ++
usageInfo usage options
shrink :: String -> String
shrink s = s -- if length s > 1000 then take 1000 s ++ "..." else s
-- Initialize the main loop
initLoop :: [Flag] -> FilePath -> History -> IO ()
initLoop flags f hist = do
-- Parse and type check files
(_,_,mods) <- E.catch (imports True ([],[],[]) f)
(\e -> do putStrLn $ unlines $
("Exception: " :
(takeWhile (/= "CallStack (from HasCallStack):")
(lines $ show (e :: SomeException))))
return ([],[],[]))
-- Translate to TT
let res = runResolver $ resolveModules mods
case res of
Left err -> do
putStrLn $ "Resolver failed: " ++ err
runInputT (settings []) (putHistory hist >> loop flags f [] TC.verboseEnv)
Right (adefs,names) -> do
-- After resolivng the file check if some definitions were shadowed:
let ns = map fst names
uns = nub ns
dups = ns \\ uns
unless (dups == []) $
putStrLn $ "Warning: the following definitions were shadowed [" ++
intercalate ", " dups ++ "]"
(merr,tenv) <- TC.runDeclss TC.verboseEnv adefs
case merr of
Just err -> putStrLn $ "Type checking failed: " ++ shrink err
Nothing -> unless (mods == []) $ putStrLn "File loaded."
if Batch `elem` flags
then return ()
else -- Compute names for auto completion
runInputT (settings [n | (n,_) <- names])
(putHistory hist >> loop flags f names tenv)
-- The main loop
loop :: [Flag] -> FilePath -> [(CTT.Ident,SymKind)] -> TC.TEnv -> Interpreter ()
loop flags f names tenv = do
input <- getInputLine prompt
case input of
Nothing -> outputStrLn help >> loop flags f names tenv
Just ":q" -> return ()
Just ":r" -> getHistory >>= lift . initLoop flags f
Just (':':'l':' ':str)
| ' ' `elem` str -> do outputStrLn "Only one file allowed after :l"
loop flags f names tenv
| otherwise -> getHistory >>= lift . initLoop flags str
Just (':':'c':'d':' ':str) -> do lift (setCurrentDirectory str)
loop flags f names tenv
Just ":h" -> outputStrLn help >> loop flags f names tenv
Just str' ->
let (msg,str,mod) = case str' of
(':':'n':' ':str) ->
("NORMEVAL: ",str,E.normal [])
str -> ("EVAL: ",str,return)
in case pExp (lexer str) of
Bad err -> outputStrLn ("Parse error: " ++ err) >> loop flags f names tenv
Ok exp ->
case runResolver $ local (insertIdents names) $ resolveExp exp of
Left err -> do outputStrLn ("Resolver failed: " ++ err)
loop flags f names tenv
Right body -> do
x <- liftIO $ TC.runInfer tenv body
case x of
Left err -> do outputStrLn ("Could not type-check: " ++ err)
loop flags f names tenv
Right _ -> do
start <- liftIO getCurrentTime
e <- liftIO $ runEval $ join (mod <$> E.eval (TC.env tenv) body)
-- Let's not crash if the evaluation raises an error:
liftIO $ catch (putStrLn (msg ++ shrink (show e)))
(\e -> putStrLn ("Exception: " ++
show (e :: SomeException)))
stop <- liftIO getCurrentTime
-- Compute time and print nicely
let time = diffUTCTime stop start
secs = read (takeWhile (/='.') (init (show time)))
rest = read ('0':dropWhile (/='.') (init (show time)))
mins = secs `quot` 60
sec = printf "%.3f" (fromInteger (secs `rem` 60) + rest :: Float)
when (Time `elem` flags) $
outputStrLn $ "Time: " ++ show mins ++ "m" ++ sec ++ "s"
-- Only print in seconds:
-- when (Time `elem` flags) $ outputStrLn $ "Time: " ++ show time
loop flags f names tenv
-- (not ok,loaded,already loaded defs) -> to load ->
-- (new not ok, new loaded, new defs)
-- the bool determines if it should be verbose or not
imports :: Bool -> ([String],[String],[Module]) -> String ->
IO ([String],[String],[Module])
imports v st@(notok,loaded,mods) f
| f `elem` notok = error ("Looping imports in " ++ f)
| f `elem` loaded = return st
| otherwise = do
b <- doesFileExist f
when (not b) $ error (f ++ " does not exist")
let prefix = dropFileName f
s <- readFile f
let ts = lexer s
case pModule ts of
Bad s -> error ("Parse failed in " ++ show f ++ "\n" ++ show s)
Ok mod@(Module (AIdent (_,name)) imp decls) -> do
let imp_ytt = [prefix ++ i ++ ".ytt" | Import (AIdent (_,i)) <- imp]
when (name /= dropExtension (takeFileName f)) $
error ("Module name mismatch in " ++ show f ++ " with wrong name " ++ name)
(notok1,loaded1,mods1) <-
foldM (imports v) (f:notok,loaded,mods) imp_ytt
when v $ putStrLn $ "Parsed " ++ show f ++ " successfully!"
return (notok,f:loaded1,mods1 ++ [mod])
help :: String
help = "\nAvailable commands:\n" ++
" <statement> infer type and evaluate statement\n" ++
" :n <statement> normalize statement\n" ++
" :q quit\n" ++
" :l <filename> loads filename (and resets environment before)\n" ++
" :cd <path> change directory to path\n" ++
" :r reload\n" ++
" :h display this message\n"