-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathCompiler.hs
247 lines (206 loc) · 8.98 KB
/
Compiler.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
208
209
210
211
212
213
214
215
216
217
218
219
220
221
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
module Main where
import System.IO ( stdin, hGetContents )
import System.Environment ( getArgs, getProgName )
import System.Exit ( exitFailure, exitSuccess )
import Control.Monad (when)
import Data.List
import LexRnb
import ParRnb
import SkelRnb
import AbsRnb
import PrettyPrinter
import StaticAnalysis
import TACGenerator
import Utils
import ErrM
type ParseFun a = [Token] -> Err a
myLLexer = myLexer
type Verbosity = Int
putStrV :: Verbosity -> String -> IO ()
putStrV v s = when (v < 1) $ putStrLn s
putStrC :: Verbosity -> String -> IO ()
putStrC v s = when (v == 6) $ putStrLn s
putStrN :: Verbosity -> String -> IO ()
putStrN v s = when (v < 3) $ putStrLn s
putStrS :: Verbosity -> String -> IO ()
putStrS v s = when (v ==4 ) $ putStrLn s
putStrT :: Verbosity -> String -> IO ()
putStrT v s = when (v == 5) $ putStrLn s
putStrNC :: Verbosity -> String -> IO()
putStrNC v s = when (v==7) $ putStrLn s
compile :: Verbosity -> ParseFun Program -> FilePath -> IO ()
compile v p f = putStrLn f >> readFile f >>= run v p
run :: Verbosity -> ParseFun Program -> String -> IO ()
run v p s = let ts = myLLexer s in case p ts of
Bad s -> do putStrLn (colorRed "[PARSING]: FAIL" )
putStrLn $ errorMsg s
exitFailure
Ok tree -> do putStrN v $ "\n"++(colorGreen "[PARSING]: PASS")
putStrNC v $ "\n[PARSING]: PASS"
putStrT v (testingTAC (generateTAC tree) s)
x <-testing tree s
putStrC v x
putStrV v $ typ
putStrN v $ err
putStrNC v $ removeAnsi typ
putStrNC v $ removeAnsi err
--putStrN v ( StaticAnalysis.printEnv ( rnbStaticAnalysis tree))
if(nErr==0) then
do
putStrS v $ (silentAnalysis)
putStrN v $ (infoMsg "TAC Generator\n")++(prettyTAC (generateTAC tree))
putStrNC v $ removeAnsi ((infoMsg "TAC Generator\n")++(prettyTAC (generateTAC tree)))
--putStrV v $ (infoMsg "TAC State\n")++(printState $ genProgram tree)
else
exitSuccess
exitSuccess
where (typ,err,silentAnalysis, nErr) = showTree tree s
-- Helpers
listPosition :: [String] -> [(String,Pos)] -> [(String, (String,Pos))]
listPosition _ [] = []
listPosition list (p:pos) =case snd p of
(0,0) -> (list!!((fst(snd p))), p) : (listPosition list pos)
otherwise -> (list!!((fst(snd p))-1), p) : (listPosition list pos)
printErrs errs = map printTypechekerError errs
printTypechekerError :: (String , (String , Pos)) -> String
printTypechekerError (code, (err, (_, col))) = case col == 0 of
False ->
err++"\n" ++
code++"\n" ++
underlineError ((replicate (col-1) '~' )++ "^")
True -> err++"\n"
sortErr :: (String,(String,Pos)) -> (String,(String,Pos))-> Ordering
sortErr (_,(_,p1)) (_,(_,p2)) = sortPos p1 p2
where sortPos (lin,col) (lin2,col2)
| lin < lin2 = LT
| lin > lin2 = GT
| lin == lin2 && col < col2 = LT
| otherwise = GT
countError :: [(String,Pos)] -> Int
countError [] = 0
countError ((x,_):xs) = case isInfixOf "[Error]:" x of
True -> 1 + countError xs
False -> countError xs
showTree :: Program -> String -> (String,String,String,Int)
showTree tree s= (("\n"++infoMsg ("Abstract Syntax Tree\n") ++
prettyTree tree) ++"\n", unlines (printErrs (sortBy sortErr (listPosition listTree envErrorsPos)))++"\n" ++
numOfErrors,silentAnalysis,errCount)
where envErrorsPos = errors (rnbStaticAnalysis tree)
errCount = countError envErrorsPos
listTree = lines s
silentAnalysis | length envErrorsPos - errCount > 0 = colorYellow "[STATIC ANALYSIS]: PASS"
| otherwise = colorGreen "[STATIC ANALYSIS]: PASS"
numOfErrors | length envErrorsPos ==0 = colorGreen "[STATIC ANALYSIS]: PASS"
| errCount == 0 = (warningMsg ("Found "++ (show $ (length envErrorsPos - errCount)) ++ " warnigs."))
| otherwise = ( errorMsg("Found " ++ (show errCount)) ++ " errors"
++"\n"++warningMsg ("Found "++ (show $ (length envErrorsPos - errCount)) ++ " warnigs."))
usage :: IO ()
usage = do
putStrLn $ unlines
[ " ___ _ _____ _____ ",
" / _ \\/ |/ / _ )/ ___/ ",
" / , _/ / _ / /__ ",
"/_/|_/_/|_/____/\\___/ompiler " ,
""
, " --help Display this help message."
, " (files) Parse content of files verbosely."
, " --check (files) Check the correctness of the RNBStaticAnalysis with the powerful Test-Suite."
, " --verbose (files) Show all prints. "
, " --silent (files) Remove all prints. "
, " --checkTAC (files) Check if the generated TAC is equal to the expected TAC."
, " --nocolor (files) Print output without colors."
]
exitFailure
emptyInputError :: IO ()
emptyInputError = do
putStrLn (errorMsg "You have to provide an input file.")
exitFailure
main :: IO ()
main = do
args <- getArgs
case args of
["--help"] -> usage
["--version"] -> putStrLn $ unlines
[ " ___ _ _____ _____ ",
" / _ \\/ |/ / _ )/ ___/ ",
" / , _/ / _ / /__ ",
"/_/|_/_/|_/____/\\___/ompiler " ,
"","The almighty RNB compiler. V0.1"]
[] -> emptyInputError
"--check":fs | checkExtension fs -> mapM_ (compile 6 pProgram) fs
| otherwise -> putStrLn (errorMsg "Unrecognized extension.")
"--checkTAC":fs | checkExtension fs -> mapM_ (compile 5 pProgram) fs
| otherwise -> putStrLn (errorMsg "Unrecognized extension.")
"--verbose":fs | checkExtension fs -> mapM_ (compile 0 pProgram) fs
| otherwise -> putStrLn (errorMsg "Unrecognized extension.")
"--silent":fs | checkExtension fs -> mapM_ (compile 4 pProgram) fs
| otherwise -> putStrLn (errorMsg "Unrecognized extension.")
"--nocolor":fs | checkExtension fs -> mapM_ (compile 7 pProgram) fs
| otherwise -> putStrLn (errorMsg "Unrecognized extension.")
fs | checkExtension fs -> mapM_ (compile 2 pProgram) fs
| otherwise -> putStrLn (errorMsg "Unrecognized extension.")
checkExtension:: [String] -> Bool
checkExtension [] = True
checkExtension (f:fs) | ".r" == (drop (length f - 2 )f) = checkExtension fs
| otherwise = False
------------------------------------------------------
-- TESTING UNIT
------------------------------------------------------
testing ::Program->String -> IO(String)
testing tree s = do
let file = lines s
let errEx = removeCode file
let envErrorPos = errors (rnbStaticAnalysis tree)
let envFilter = removeColor envErrorPos
let output = test errEx envFilter
return (output)
removeColor :: [(String,Pos)] -> [(String,Pos)]
removeColor [] = []
removeColor ((s,p):xs) =(fin,p) : removeColor xs
where fin1 = drop 28 s
fin2 = takeWhile (/='\ESC') fin1
fin3 = dropWhile (/='\ESC') fin1
fin4 = drop 7 fin3
fin5 = fin2 ++ fin4
fin = filter (/= '\n') fin5
removeCode :: [String] -> [String]
removeCode [] = []
removeCode (x:xs)
| isInfixOf "==" x = (drop 2 x) : removeCode xs
| otherwise = removeCode xs
test :: [String] -> [(String, Pos)] -> String
test [] [] = colorGreen "[CHECK]: PASS"
test [] ((s,_):_) =colorRed "[CHECK]: FAIL " ++ s
test (x:_) [] = colorRed "[CHECK]: FAIL EXPECTED " ++ x
test (x:xs) ((s,_):ys)
| x == s = test xs ys
| otherwise = colorRed "[CHECK]: FAIL " ++ s
removeAnsiList :: [String] -> [String]
removeAnsiList [] = []
removeAnsiList (x:xs) = (removeAnsi x) : removeAnsiList xs
removeAnsi :: String -> String
removeAnsi x
| (elem '\ESC' x) = removeAnsi y
| otherwise = x
where x1 = takeWhile (/= '\ESC') x
x2 = dropWhile (/= '\ESC') x
x3 = dropWhile (/= 'm') x2
x4 = drop 1 x3
y = x1 ++ x4
testingTAC :: [TAC] -> String -> String
testingTAC tac prog = testTAC listTAC progTAC
where stringTAC = prettyTAC tac
listTAC1 = lines stringTAC
listTAC = removeAnsiList listTAC1
progTAC1 = dropWhile (/= '{') prog
progTAC2 = drop 2 progTAC1
progTAC3 = take (length progTAC2 -2) progTAC2
progTAC = lines progTAC3
testTAC :: [String] -> [String] -> String
testTAC [] [] = colorGreen "[CHECK]: PASS"
testTAC [] (s:_) = colorRed "[CHECK]: FAIL EXPECTED" ++ s
testTAC (x:_) [] = colorRed "[CHECK]: FAIL MISSING" ++ x
testTAC (x:xs) (s:ys)
| x == s = testTAC xs ys
| otherwise = colorRed "[CHECK]: FAIL \nEXPECTED :" ++ s
++ colorRed"\nFOUND :"++ x