-
Notifications
You must be signed in to change notification settings - Fork 1
/
Test.hs
137 lines (119 loc) · 4.35 KB
/
Test.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
module WebBits.Test
( pretty
, parse
, parseJavaScriptFromFile
, label
, globals
, isJsFile
, getJsPaths
, sameIds
, diffIds
, commandIO
, module Test.HUnit
) where
import qualified Data.List as L
import Data.List ( isSuffixOf )
import Data.Maybe (catMaybes)
import qualified Data.Foldable as Foldable
import Data.Foldable (Foldable)
import Control.Monad
import qualified Data.Map as M
import System.Directory
import System.FilePath
import System.IO.Unsafe ( unsafePerformIO )
import Data.Generics
import Test.HUnit
import qualified Data.ByteString.Char8 as B
import System.Process
import System.IO
import System.Exit
import Text.PrettyPrint.HughesPJ ( render, vcat )
import Text.ParserCombinators.Parsec (ParseError,sourceName,sourceLine,
sourceColumn,errorPos,SourcePos)
import WebBits.Common ( pp )
import WebBits.JavaScript.PrettyPrint ()
import WebBits.JavaScript.Syntax
import WebBits.JavaScript.Parser (parseScriptFromString,parseJavaScriptFromFile,
ParsedStatement)
import WebBits.JavaScript.Environment (LabelledStatement,LabelledExpression,
Ann,staticEnvironment,Env)
pretty :: [ParsedStatement] -> String
pretty stmts = render $ vcat $ map pp stmts
isPrettyPrintError :: ParseError -> Bool
isPrettyPrintError pe =
"(PRETTY-PRINTING)" `isSuffixOf` sourceName (errorPos pe)
parse :: FilePath -> String -> [ParsedStatement]
parse src str = case parseScriptFromString src str of
Left err | isPrettyPrintError err ->
(unsafePerformIO $ putStrLn str) `seq` error (show err)
| otherwise -> error (show err)
Right (Script _ stmts) -> stmts
isJsFile :: String -> Bool
isJsFile = (== ".js") . takeExtension
getJsPaths :: FilePath -> IO [FilePath]
getJsPaths dpath = do
exists <- doesDirectoryExist dpath
paths <- if exists then getDirectoryContents dpath else return []
return [dpath </> p | p <- paths, isJsFile p]
globals :: [ParsedStatement] -> [String]
globals stmts = M.keys env where
(_,_,env,_) = staticEnvironment stmts
label :: [ParsedStatement] -> [LabelledStatement]
label stmts = labelledStmts where
(labelledStmts,_,_,_) = staticEnvironment stmts
idWithPos :: (Int,Int)
-> Id Ann
-> [Int]
idWithPos (line,col) (Id (_,lbl,pos) _)
| line == sourceLine pos && col == sourceColumn pos = [lbl]
idWithPos _ _ = []
labelAt :: (Foldable t)
=> [t (a,Int,SourcePos)]
-> (Int,Int) -- ^row and column
-> Int
labelAt terms (line,column) =
let match loc = sourceLine loc == line && sourceColumn loc == column
results = map (Foldable.find (\(_,_,loc) -> match loc)) terms
in case catMaybes results of
((_,lbl,_):_) -> lbl
[] -> error ("Test.Ovid.Scripts.LabelAt: no term at line " ++
show line ++ ", column " ++ show column)
sameIds :: [(Int,Int)] -- ^positions of identifiers that reference the same
-- variable
-> [LabelledStatement]
-> Assertion
sameIds [] stmts =
assertFailure "sameIds called with no identifiers"
sameIds idLocs stmts = do
let lbls = map (labelAt stmts) idLocs
when (length (L.nub lbls) /= 1) $
assertFailure $ "sameIds: distinct labels in " ++ show lbls
return ()
diffIds :: [(Int,Int)] -- ^positions of identifiers that reference distinct
-- variables
-> [LabelledStatement]
-> Assertion
diffIds idLocs stmts = do
let lbls = map (labelAt stmts) idLocs
when (L.nub lbls /= lbls) $
assertFailure $ "diffIds : some labels are the same in " ++ show lbls
return ()
commandIO :: FilePath -- ^path of the executable
-> [String] -- ^command line arguments
-> B.ByteString -- ^stdin
-> IO (Maybe B.ByteString) -- ^stdout or 'Nothing' on failure
commandIO path args stdinStr = do
let cp = CreateProcess (RawCommand path args) Nothing Nothing CreatePipe
CreatePipe CreatePipe True
(Just hStdin, Just hStdout, Just hStderr, hProcess) <- createProcess cp
B.hPutStr hStdin stdinStr
stdoutStr <- B.hGetContents hStdout
stderrStr <- hGetContents hStderr
hPutStrLn stderr stderrStr -- echo errors to our stderr
exitCode <- waitForProcess hProcess
case exitCode of
ExitSuccess -> return (Just stdoutStr)
ExitFailure n -> do
B.hPutStrLn stdout stdoutStr -- echo for errors
hPutStrLn stderr $ "Sub-process died with exit code " ++ show n
return Nothing