git.iko.soy/elk
on bd2ab82 help sign in
elk/tests/Test/Compiler.hs
247 lines 6.7 kB history raw
1{-# OPTIONS_GHC -W #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4module Test.Compiler (compilerTests) where
6import Control.Exception (try, IOException)
8import qualified Data.Text.Lazy as LText
9import qualified Data.Text.Lazy.IO as LText
10import qualified Data.Map as Map
11import Data.Maybe (isJust)
12import qualified Data.Text.IO as Text
13import Data.Text (Text)
15import System.Directory (createDirectoryIfMissing)
16import System.Environment (lookupEnv)
17import System.FilePath ((</>), (<.>), dropFileName, joinPath, splitDirectories)
18import System.FilePath.Find (find, (==?), extension)
20import Test.Framework
21import Test.Framework.Providers.HUnit (testCase)
22import Test.HUnit (Assertion, assertFailure, assertBool, assertEqual)
24import qualified Elm.Compiler as Compiler
25import qualified Elm.Package as Package
26import qualified AST.Module as Module
27import qualified AST.Module.Name as ModuleName
28import qualified AST.Variable as Variable
29import qualified AST.Type as Type
33-- TESTS
36writeExpectedJsEnvVarName :: String
37writeExpectedJsEnvVarName =
38 "ELM_WRITE_NEW_EXPECTED"
41compilerTests :: Test
42compilerTests =
43 buildTest $
44 do goods <- testIf isSuccess =<< getElms "good"
45 bads <- testIf isFailure =<< getElms "bad"
46 expectedJsTests <- testMatchesExpected "good" "good-expected-js"
47 return $
48 testGroup "Compile Tests"
49 [ testGroup "Good Tests" goods
50 , testGroup "Bad Tests" bads
51 , testGroup "Expected JS Tests" expectedJsTests
52 ]
56-- GATHER FILES
59getElms :: FilePath -> IO [FilePath]
60getElms filePath =
61 find
62 (return True)
63 (extension ==? ".elm")
64 (testsDir </> filePath)
67testsDir :: FilePath
68testsDir =
69 "tests" </> "test-files"
72convertToExpectedJsFilePath :: String -> FilePath -> FilePath
73convertToExpectedJsFilePath expectedJsDir filePath =
74 testsDir
75 </> expectedJsDir
76 </> joinPath (drop 3 (splitDirectories filePath))
77 <.> ".js"
81-- COMPILE HELPERS
84compile :: FilePath -> Text -> Either String Compiler.Result
85compile filePath source =
86 let
87 context =
88 Compiler.Context Package.core False importDict interfaces
90 (dealiaser, _warnings, result) =
91 Compiler.compile context source
93 formatErrors errors =
94 concatMap (Compiler.errorToString dealiaser filePath source) errors
95 in
96 either (Left . formatErrors) Right result
99importDict :: Map.Map ModuleName.Raw ModuleName.Canonical
100importDict =
101 let
102 toPair name =
103 ( ModuleName._module name, name )
104 in
105 Map.fromList $ map toPair $ Map.keys interfaces
108interfaces :: Module.Interfaces
109interfaces =
110 Map.fromList
111 [
112 (ModuleName.inCore "Debug",
113 buildCoreInterface
114 [
115 ("crash", Type.Lambda (Type.Var "String") (Type.Var "a"))
116 ]
117 )
118 ]
121buildCoreInterface :: [(Text, Type.Canonical)] -> Module.Interface
122buildCoreInterface members =
123 let
124 exports = map (Variable.Value . fst) members
125 imports = []
126 types = Map.fromList members
127 adts = Map.empty
128 aliases = Map.empty
129 fixities = []
130 in
131 Module.Interface Compiler.version Package.core exports imports types adts aliases fixities
135-- FILE HELPER
138readFileOrErrorStr :: FilePath -> IO String
139readFileOrErrorStr filePath =
140 do strOrExc <- try $ readFile filePath
141 case strOrExc of
142 Right s ->
143 return s
145 Left (e :: IOException) ->
146 return (show e)
150-- RUN TESTS
153testIf
154 :: (Either String Compiler.Result -> Assertion)
155 -> [FilePath]
156 -> IO [Test]
157testIf handleResult filePaths =
158 let doTest filePath =
159 do source <- Text.readFile filePath
160 let formattedResult = compile filePath source
161 return $ testCase filePath (handleResult formattedResult)
162 in
163 traverse doTest filePaths
166doMatchesExpectedTest :: String -> FilePath -> IO Test
167doMatchesExpectedTest expectedJsDir filePath =
168 do source <- Text.readFile filePath
169 expectedJs <- readFileOrErrorStr (convertToExpectedJsFilePath expectedJsDir filePath)
171 let formattedResult = compile filePath source
172 let assertion = matchesExpected expectedJs formattedResult
174 return $ testCase filePath assertion
177doWriteNewExpectedTest :: String -> FilePath -> IO Test
178doWriteNewExpectedTest expectedJsDir filePath =
179 do source <- Text.readFile filePath
180 let formattedResult = compile filePath source
181 let expectedFilePath = convertToExpectedJsFilePath expectedJsDir filePath
182 let assertion =
183 case formattedResult of
184 Right (Compiler.Result _ _ js) ->
185 do createDirectoryIfMissing True (dropFileName expectedFilePath)
186 -- Force the evaluation of `js` before `writeFile`
187 -- so that if an error is raised we do not unintentionally write an empty file.
188 -- NB: `js` can be an empty string in the case of NoExpressions.elm
189 assertBool "" (LText.length js >= 0)
190 LText.writeFile expectedFilePath js
191 assertFailure ("Wrote new expected js: " ++ expectedFilePath)
193 _ ->
194 assertFailure "Compile failed. Could not write new expected js."
195 return $ testCase filePath assertion
198testMatchesExpected :: String -> String -> IO [Test]
199testMatchesExpected elmDir expectedJsDir =
200 do elmFiles <- getElms elmDir
201 envVar <- lookupEnv writeExpectedJsEnvVarName
202 if isJust envVar
203 then
204 traverse (doWriteNewExpectedTest expectedJsDir) elmFiles
205 else
206 traverse (doMatchesExpectedTest expectedJsDir) elmFiles
210-- CHECK RESULTS
213isSuccess :: Either String a -> Assertion
214isSuccess result =
215 case result of
216 Right _ ->
217 assertBool "" True
219 Left errorMessages ->
220 assertFailure errorMessages
223isFailure :: Either a b -> Assertion
224isFailure result =
225 case result of
226 Right _ ->
227 assertFailure "Compilation succeeded but should have failed"
229 Left _ ->
230 assertBool "" True
233matchesExpected :: String -> Either String Compiler.Result -> Assertion
234matchesExpected expectedJs result =
235 case result of
236 Right (Compiler.Result _ _ js) ->
237 assertEqual matchFailureMessage (LText.pack expectedJs) js
239 Left errorMessages ->
240 assertFailure $ "Compile failed:\n" ++ errorMessages
243matchFailureMessage :: String
244matchFailureMessage =
245 "Compiled JS did not match expected JS." ++
246 "\n If the change is intentional, rerun " ++
247 "the tests with environment variable: " ++ writeExpectedJsEnvVarName ++ "=1"