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
|
{-# LANGUAGE OverloadedStrings, PackageImports, LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
module Main where
import Data.List
import Control.Applicative
import Control.Arrow
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.Reader
import System.Environment
import System.Exit
import System.Directory
import System.FilePath
import System.IO
import Control.Exception hiding (catch)
import Control.Monad.Trans.Control
import Control.Monad.Catch
import Control.DeepSeq
import qualified Data.Set as Set
import LambdaCube.Compiler.Pretty hiding ((</>))
import LambdaCube.Compiler.CGExp (tyOf, outputType, boolType, trueExp)
import LambdaCube.Compiler.Driver
import LambdaCube.Compiler.CoreToIR
import IR (Backend(..))
import Text.Parsec.Pos
instance NFData SourcePos where
rnf _ = ()
acceptPath = "./testdata/accept"
rejectPath = "./testdata/reject"
timeout = 15 {- in seconds -}
data Res = Accepted | New | Rejected | Failed | ErrorCatched
deriving (Eq, Ord, Show)
erroneous = (>= Rejected)
instance NFData Res where
rnf a = a `seq` ()
optionArgs = ["-v", "-r"]
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
hSetBuffering stdin NoBuffering
args <- getArgs
let samplesToAccept = filter (not . flip elem optionArgs) args
verbose = elem "-v" args
reject = elem "-r" args
(testToAccept,testToReject) <- case samplesToAccept of
[] -> do
toAccept <- map dropExtension . filter (\n -> ".lc" == takeExtension n) <$> getDirectoryContents acceptPath
toReject <- map dropExtension . filter (\n -> ".lc" == takeExtension n) <$> getDirectoryContents rejectPath
return (toAccept, toReject)
_ -> do
let intersect = Set.toList . Set.intersection (Set.fromList samplesToAccept) . Set.fromList
toAccept <- intersect . map dropExtension . filter (\n -> ".lc" == takeExtension n) <$> getDirectoryContents acceptPath
toReject <- intersect . map dropExtension . filter (\n -> ".lc" == takeExtension n) <$> getDirectoryContents rejectPath
return (toAccept, toReject)
n <- runMM' $ do
liftIO $ putStrLn $ "------------------------------------ Checking valid pipelines"
n1 <- acceptTests reject testToAccept
liftIO $ putStrLn $ "------------------------------------ Catching errors (must get an error)"
n2 <- rejectTests reject testToReject
return $ n1 ++ n2
let sh b ty = [(if erroneous ty then "!" else "") ++ show (length ss) ++ " " ++ pad 10 (b ++ ": ") ++ intercalate ", " ss | not $ null ss]
where
ss = sort [s | (ty', s) <- n, ty' == ty]
let results = [t | (t,_) <- n]
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
when (any erroneous results) exitFailure
acceptTests reject = testFrame reject [acceptPath, rejectPath] $ \case
Left e -> Left e
Right (Left e, i) -> Right ("typechecked", unlines $ e: "tooltips:": [showRange (b, e) ++ " " ++ m | (b, e, m) <- i])
Right (Right e, i)
| True <- i `deepseq` False -> error "impossible"
| tyOf e == outputType
-> Right ("compiled main", show . compilePipeline True OpenGL33 $ e)
| e == trueExp -> Right ("main ~~> True", ppShow e)
| tyOf e == boolType -> Left $ "main should be True but it is \n" ++ ppShow e
| otherwise -> Right ("reduced main " ++ ppShow (tyOf e), ppShow e)
-- | otherwise -> Right ("System-F main ", ppShow . toCore mempty $ e)
rejectTests reject = testFrame reject [rejectPath, acceptPath] $ \case
Left e -> Right ("error message", e)
Right _ -> Left "failed to catch error"
runMM' = fmap (either (error "impossible") id . fst) . runMM (ioFetch [])
testFrame :: Bool -> [FilePath] -> (Either String (Either String Exp, Infos) -> Either String (String, String)) -> [String] -> MMT IO [(Res, String)]
testFrame reject dirs f tests
= local (const $ ioFetch dirs') . testFrame_ compare (head dirs') (\n -> do
result <- catchMM $ getDef n "main" Nothing
return $ f result) $ tests
where
compare = if reject then alwaysReject else compareResult
dirs_ = [takeDirectory f | f <- tests, takeFileName f /= f]
dirs' = if null dirs_ then dirs else dirs_
timeOut :: Int -> a -> MM a -> MM a
timeOut n d m = MMT $
control (\runInIO ->
race' (runInIO (runMMT m))
(threadDelay (n * 1000000) >> (runInIO $ return d)))
where
race' a b = either id id <$> race a b
testFrame_ compareResult 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 <- timeOut timeout (Left "Timed Out") (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
-- Reject unrigestered or chaned results automatically
alwaysReject n msg ef e = doesFileExist ef >>= \b -> case b of
False -> putStrLn ("Unregistered - " ++ msg) >> return [(Rejected, 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 "-------------------------------------------"
return [(Rejected, n)]
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' ++ replicate (abs $ length e - length e') True 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
|
