git.iko.soy/elk
on 8491fae help sign in
elk/tests/Test/Compiler.hs
229 lines 6.6 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 as Text
13import qualified Data.Text.IO as Text
14import Data.Text (Text)
16import System.Directory (createDirectoryIfMissing)
17import System.Environment (lookupEnv)
18import System.FilePath ((</>), (<.>), dropFileName, joinPath, splitDirectories)
19import System.FilePath.Find (find, (==?), extension)
21import Test.Framework
22import Test.Framework.Providers.HUnit (testCase)
23import Test.HUnit (Assertion, assertFailure, assertBool, assertEqual)
25import qualified Elm.Compiler as Compiler
26import qualified Elm.Package as Package
27import qualified AST.Module as Module
28import qualified AST.Module.Name as ModuleName
29import qualified AST.Variable as Variable
30import qualified AST.Type as Type
33writeExpectedJsEnvVarName :: String
34writeExpectedJsEnvVarName =
35 "ELM_WRITE_NEW_EXPECTED"
38compilerTests :: Test
39compilerTests =
40 buildTest $
41 do goods <- testIf isSuccess =<< getElms "good"
42 bads <- testIf isFailure =<< getElms "bad"
43 expectedJsTests <- testMatchesExpected "good" "good-expected-js"
44 return $
45 testGroup "Compile Tests"
46 [ testGroup "Good Tests" goods
47 , testGroup "Bad Tests" bads
48 , testGroup "Expected JS Tests" expectedJsTests
49 ]
53-- GATHER FILES
56getElms :: FilePath -> IO [FilePath]
57getElms filePath =
58 find
59 (return True)
60 (extension ==? ".elm")
61 (testsDir </> filePath)
64testsDir :: FilePath
65testsDir =
66 "tests" </> "test-files"
68convertToExpectedJsFilePath :: String -> FilePath -> FilePath
69convertToExpectedJsFilePath expectedJsDir filePath =
70 testsDir
71 </> expectedJsDir
72 </> joinPath (drop 3 (splitDirectories filePath))
73 <.> ".js"
77-- TEST HELPERS
80essentialInterfaces :: Module.Interfaces
81essentialInterfaces =
82 Map.fromList
83 [
84 (ModuleName.inCore "Debug",
85 buildCoreInterface
86 [
87 ("crash", Type.Lambda (Type.Var "String") (Type.Var "a"))
88 ]
89 )
90 ]
93buildCoreInterface :: [(Text, Type.Canonical)] -> Module.Interface
94buildCoreInterface members =
95 let
96 exports = map (Variable.Value . fst) members
97 imports = []
98 types = Map.fromList members
99 adts = Map.empty
100 aliases = Map.empty
101 fixities = []
102 in
103 Module.Interface Compiler.version Package.core exports imports types adts aliases fixities
106compile :: FilePath -> Text -> Either String Compiler.Result
107compile filePath source =
108 let dependentModuleNames =
109 Map.keys essentialInterfaces
110 context =
111 Compiler.Context Package.core False dependentModuleNames
112 (dealiaser, _warnings, result) =
113 Compiler.compile context source essentialInterfaces
114 formatErrors errors =
115 concatMap (Compiler.errorToString dealiaser filePath (Text.unpack source)) errors
116 in
117 either (Left . formatErrors) Right result
120readFileOrErrorStr :: FilePath -> IO String
121readFileOrErrorStr filePath =
122 do strOrExc <- try $ readFile filePath
123 case strOrExc of
124 Right s ->
125 return s
127 Left (e :: IOException) ->
128 return (show e)
132-- RUN TESTS
135testIf
136 :: (Either String Compiler.Result -> Assertion)
137 -> [FilePath]
138 -> IO [Test]
139testIf handleResult filePaths =
140 let doTest filePath =
141 do source <- Text.readFile filePath
142 let formattedResult = compile filePath source
143 return $ testCase filePath (handleResult formattedResult)
144 in
145 traverse doTest filePaths
148doMatchesExpectedTest :: String -> FilePath -> IO Test
149doMatchesExpectedTest expectedJsDir filePath =
150 do source <- Text.readFile filePath
151 expectedJs <- readFileOrErrorStr (convertToExpectedJsFilePath expectedJsDir filePath)
153 let formattedResult = compile filePath source
154 let assertion = matchesExpected expectedJs formattedResult
156 return $ testCase filePath assertion
159doWriteNewExpectedTest :: String -> FilePath -> IO Test
160doWriteNewExpectedTest expectedJsDir filePath =
161 do source <- Text.readFile filePath
162 let formattedResult = compile filePath source
163 let expectedFilePath = convertToExpectedJsFilePath expectedJsDir filePath
164 let assertion =
165 case formattedResult of
166 Right (Compiler.Result _ _ js) ->
167 do createDirectoryIfMissing True (dropFileName expectedFilePath)
168 -- Force the evaluation of `js` before `writeFile`
169 -- so that if an error is raised we do not unintentionally write an empty file.
170 -- NB: `js` can be an empty string in the case of NoExpressions.elm
171 assertBool "" (LText.length js >= 0)
172 LText.writeFile expectedFilePath js
173 assertFailure ("Wrote new expected js: " ++ expectedFilePath)
175 _ ->
176 assertFailure "Compile failed. Could not write new expected js."
177 return $ testCase filePath assertion
180testMatchesExpected :: String -> String -> IO [Test]
181testMatchesExpected elmDir expectedJsDir =
182 do elmFiles <- getElms elmDir
183 envVar <- lookupEnv writeExpectedJsEnvVarName
184 if isJust envVar
185 then
186 traverse (doWriteNewExpectedTest expectedJsDir) elmFiles
187 else
188 traverse (doMatchesExpectedTest expectedJsDir) elmFiles
192-- CHECK RESULTS
195isSuccess :: Either String a -> Assertion
196isSuccess result =
197 case result of
198 Right _ ->
199 assertBool "" True
201 Left errorMessages ->
202 assertFailure errorMessages
205isFailure :: Either a b -> Assertion
206isFailure result =
207 case result of
208 Right _ ->
209 assertFailure "Compilation succeeded but should have failed"
211 Left _ ->
212 assertBool "" True
215matchesExpected :: String -> Either String Compiler.Result -> Assertion
216matchesExpected expectedJs result =
217 case result of
218 Right (Compiler.Result _ _ js) ->
219 assertEqual matchFailureMessage (LText.pack expectedJs) js
221 Left errorMessages ->
222 assertFailure $ "Compile failed:\n" ++ errorMessages
225matchFailureMessage :: String
226matchFailureMessage =
227 "Compiled JS did not match expected JS." ++
228 "\n If the change is intentional, rerun " ++
229 "the tests with environment variable: " ++ writeExpectedJsEnvVarName ++ "=1"