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
|
{-# LANGUAGE OverloadedStrings, PackageImports, LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
import Data.List
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Reader
import System.Environment
import System.Directory
import System.FilePath
import System.IO
import Control.Exception hiding (catch)
import Control.Monad.Catch
import Control.DeepSeq
import Pretty hiding ((</>))
import Type
import Typecheck
import Parser
import Driver
import CoreToIR
import IR (Backend(..))
import Text.Parsec.Pos
instance NFData SourcePos where
rnf _ = ()
acceptPath = "./tests/accept"
rejectPath = "./tests/reject"
demoPath = "./tests/demo"
data Res = Accepted | New | Rejected | Failed | ErrorCatched
deriving (Eq, Ord, Show)
instance NFData Res where
rnf a = a `seq` ()
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
hSetBuffering stdin NoBuffering
args <- getArgs
let (verboseFlags,samplesToAccept) = partition (== "-v") args
verbose = verboseFlags /= []
(testToAccept,testToReject, demos) <- case samplesToAccept of
[] -> do
toAccept <- map dropExtension . filter (\n -> ".lc" == takeExtension n) <$> getDirectoryContents acceptPath
toReject <- map dropExtension . filter (\n -> ".lc" == takeExtension n) <$> getDirectoryContents rejectPath
demos <- map dropExtension . filter (\n -> ".lc" == takeExtension n) <$> getDirectoryContents demoPath
return (toAccept, toReject, demos)
_ -> return (samplesToAccept, [], [])
n' <- runMM' $ do
liftIO $ putStrLn $ "------------------------------------ Checking valid pipelines"
n1 <- acceptTests testToAccept
liftIO $ putStrLn $ "------------------------------------ Catching errors (must get an error)"
n2 <- rejectTests testToReject
return $ n1 ++ n2
putStrLn $ "------------------------------------ Checking demos"
n'' <- if null demos then return [] else do
compiler <- preCompile [acceptPath] WebGL1 "DemoUtils"
demoTests compiler demos
let n = n' ++ n''
let sh a b ty = [a ++ show (length ss) ++ " " ++ pad 10 (b ++ ": ") ++ intercalate ", " ss | not $ null ss]
where
ss = sort [s | (ty', s) <- n, ty' == ty]
putStrLn $ "------------------------------------ Summary\n" ++
if null n
then "All OK"
else unlines $
sh "!" "crashed test" ErrorCatched
++ sh "!" "failed test" Failed
++ sh "!" "rejected result" Rejected
++ sh "" "new result" New
++ sh "" "accepted result" Accepted
writeReduced = runMM' . (testFrame [acceptPath] $ \case
Left e -> Left e
Right (Left e) -> Right ("typechecked", show e)
Right (Right e) -> Right ("reduced main ", ppShow e))
main' x = runMM' $ acceptTests [x]
main'_ xs = do
toAccept <- map dropExtension . filter (\n -> ".lc" == takeExtension n) <$> getDirectoryContents acceptPath
runMM' $ acceptTests $ toAccept \\ xs
main'' x = runMM' $ rejectTests [x]
main''_ xs = do
fs <- map dropExtension . filter (\n -> ".lc" == takeExtension n) <$> getDirectoryContents rejectPath
runMM' $ rejectTests $ fs \\ xs
acceptTests = testFrame [acceptPath, rejectPath] $ \case
Left e -> Left e
Right (Left e) -> Right ("typechecked", show e)
Right (Right e)
| tyOf e == TCon0 "Output"
-> Right ("compiled main", show . compilePipeline True OpenGL33 $ e)
| tyOf e == TCon0 "Bool" -> case e of
x@(A0 "True") -> Right ("main ~~> True", ppShow x)
x -> Left $ "main should be True but it is \n" ++ ppShow x
| otherwise -> Right ("reduced main " ++ ppShow (tyOf e), ppShow e)
-- | otherwise -> Right ("System-F main ", ppShow . toCore mempty $ e)
demoTests :: (String -> IO (Err (Pipeline, Infos))) -> [String] -> IO [(Res, String)]
demoTests compiler = testFrame_ demoPath $ \f -> do
s <- readFile $ demoPath </> f ++ ".lc"
(res, infos) <- compiler s
return $ show +++ (\(pl, infos) -> infos `deepseq` ("compiled main", show pl)) $ res
rejectTests = testFrame [rejectPath, acceptPath] $ \case
Left e -> Right ("error message", e)
Right (Left e) -> Left "failed to catch error"
Right (Right e) -> Left "failed to catch error"
runMM' = fmap (either (error "impossible") id . fst) . runMM freshTypeVars (ioFetch [])
testFrame dirs f tests
= local (const $ ioFetch dirs') . testFrame_ (head dirs') (\n -> do
result <- catchMM $ getDef (ExpN n) (ExpN "main") Nothing
return $ f (((\(r, infos) -> infos `deepseq` r) <$>) <$> result)) $ tests
where
dirs_ = [takeDirectory f | f <- tests, takeFileName f /= f]
dirs' = if null dirs_ then dirs else dirs_
testFrame_ path action tests = fmap concat $ forM (zip [1..] (tests :: [String])) $ \(i, n) -> do
let er e = do
liftIO $ putStrLn $ "\n!Crashed " ++ n ++ "\n" ++ tab e
return [(ErrorCatched, n)]
catchErr er $ do
result <- action n
liftIO $ case result of
Left e -> do
putStrLn $ "\n!Failed " ++ n ++ "\n" ++ tab e
return [(Failed, n)]
Right (op, x) -> do
length x `seq` compareResult n (pad 15 op) (path </> (n ++ ".out")) x
where
tab = unlines . map (" " ++) . lines
compareResult n msg ef e = doesFileExist ef >>= \b -> case b of
False -> writeFile ef e >> putStrLn ("OK - " ++ msg ++ " is written") >> return [(New, n)]
True -> do
e' <- readFile ef
case map fst $ filter snd $ zip [0..] $ zipWith (/=) e e' of
[] -> return []
rs -> do
putStrLn $ msg ++ " has changed."
putStrLn "------------------------------------------- Old"
putStrLn $ showRanges ef rs e'
putStrLn "------------------------------------------- New"
putStrLn $ showRanges ef rs e
putStrLn "-------------------------------------------"
putStr $ "Accept new " ++ msg ++ " (y/n)? "
c <- length e' `seq` getChar
if c `elem` ("yY\n" :: String)
then writeFile ef e >> putStrLn " - accepted." >> return [(Accepted, n)]
else putStrLn " - not Accepted." >> return [(Rejected, n)]
pad n s = s ++ replicate (n - length s) ' '
limit :: String -> Int -> String -> String
limit msg n s = take n s ++ if null (drop n s) then "" else msg
showRanges :: String -> [Int] -> String -> String
showRanges fname is e = (if head rs == 0 then "" else "...\n")
++ limit ("\n... (see " ++ fname ++ " for more differences)") 140000 (intercalate "\n...\n" $ f (zipWith (-) rs (0:rs)) e)
where
f :: [Int] -> String -> [String]
f (i:is) e = g is $ drop i e
f [] "" = []
f [] _ = ["\n..."]
g (i:is) e = take i e: f is (drop i e)
rs = (head is - x) : concat [[a + x, b - x] | (a, b) <- zip is (tail is), a + y < b] ++ [last is + x]
x = 100000
y = 3*x
|
