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
|
{-# 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.Driver
import LambdaCube.Compiler.CoreToIR
import IR (Backend(..))
import Text.Parsec.Pos
instance NFData SourcePos where
rnf _ = ()
testDataPath = "./testdata"
data Res = Accepted | New | Rejected | Failed | ErrorCatched
deriving (Eq, Ord, Show)
erroneous = (>= Rejected)
instance NFData Res where
rnf a = a `seq` ()
optionArgs = ["-v", "-r","-notimeout"]
getDirectoryContentsRecursive path = do
l <- map (path </>) . filter (\n -> notElem n [".",".."]) <$> getDirectoryContents path
-- ignore sub directories that name include .ignore
dirs <- filter (not . isInfixOf ".ignore") <$> filterM doesDirectoryExist l
files <- filterM doesFileExist l
innerContent <- mapM getDirectoryContentsRecursive dirs
return $ concat $ (filter ((".lc" ==) . takeExtension) files) : innerContent
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
timeout = if elem "-notimeout" args then 15 * 60 else 15 {- in seconds -}
testData <- getDirectoryContentsRecursive testDataPath
let (testToAccept,testToReject) = case samplesToAccept of
[] ->
let toAccept = map dropExtension . filter (\n -> ".lc" == takeExtensions n) $ testData
toReject = map dropExtension . filter (\n -> ".reject.lc" == takeExtensions n) $ testData
in (toAccept, toReject)
_ ->
let samples = Set.toList . Set.fromList $ concat [filter (isInfixOf s) testData | s <- samplesToAccept]
toAccept = map dropExtension . filter (\n -> ".lc" == takeExtensions n) $ samples
toReject = map dropExtension . filter (\n -> ".reject.lc" == takeExtensions n) $ samples
in (toAccept, toReject)
when (null $ testToAccept ++ testToReject) $ do
liftIO $ putStrLn $ "test files not found: " ++ show samplesToAccept
exitFailure
n <- runMM' $ do
liftIO $ putStrLn $ "------------------------------------ Checking valid pipelines"
n1 <- acceptTests timeout reject testToAccept
liftIO $ putStrLn $ "------------------------------------ Catching errors (must get an error)"
n2 <- rejectTests timeout 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 timeout reject = testFrame timeout reject [".",testDataPath] $ \case
Left e -> Left e
Right (fname, Left e, i) -> Right ("typechecked", unlines $ e: "tooltips:": [showRange (b, e) ++ " " ++ m | (b, e, m) <- nub{-temporal; TODO: fail in case of duplicate items-} i, sourceName b == fname])
Right (fname, Right e, i)
| True <- i `deepseq` False -> error "impossible"
| tyOf e == outputType
-> Right ("compiled main", show . compilePipeline 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 timeout reject = testFrame timeout reject [".",testDataPath] $ \case
Left e -> Right ("error message", e)
Right _ -> Left "failed to catch error"
runMM' = fmap (either (error "impossible") id . fst) . runMM (ioFetch [])
testFrame :: Int -> Bool -> [FilePath] -> (Either String (FilePath, Either String Exp, Infos) -> Either String (String, String)) -> [String] -> MMT IO [(Res, String)]
testFrame timeout reject dirs f tests
= local (const $ ioFetch dirs')
$ testFrame_
timeout
(if reject then alwaysReject else compareResult)
(head dirs')
(\n -> f <$> (Right <$> getDef n "main" Nothing) `catchMM` (return . Left . show))
tests
where
dirs_ = [takeDirectory f | f <- tests, takeFileName f /= f]
dirs' = dirs ++ dirs_ -- if null dirs_ then dirs else dirs_
timeOut :: Int -> a -> MM a -> MM a
timeOut n d = mapMMT $ \m ->
control (\runInIO ->
race' (runInIO m)
(threadDelay (n * 1000000) >> (runInIO $ return d)))
where
race' a b = either id id <$> race a b
testFrame_ timeout 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
|
