git.iko.soy/rowtype-yoga/purescript-native
on 2cd12ce help sign in
rowtype-yoga/purescript-native/tests/Main.hs
242 lines 8.0 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Main
4-- License : MIT (http://opensource.org/licenses/MIT)
5--
6-- Maintainer : Phil Freeman <paf31@cantab.net>
7-- Stability : experimental
8-- Portability :
9--
10-- |
11--
12-----------------------------------------------------------------------------
14{-# LANGUAGE DataKinds #-}
15{-# LANGUAGE DoAndIfThenElse #-}
16{-# LANGUAGE TupleSections #-}
17{-# LANGUAGE FlexibleInstances #-}
19-- Failing tests can specify the kind of error that should be thrown with a
20-- @shouldFailWith declaration. For example:
21--
22-- "-- @shouldFailWith TypesDoNotUnify"
23--
24-- will cause the test to fail unless that module fails to compile with exactly
25-- one TypesDoNotUnify error.
26--
27-- If a module is expected to produce multiple type errors, then use multiple
28-- @shouldFailWith lines; for example:
29--
30-- -- @shouldFailWith TypesDoNotUnify
31-- -- @shouldFailWith TypesDoNotUnify
32-- -- @shouldFailWith TransitiveExportError
33--
35module Main (main) where
37import Prelude ()
38import Prelude.Compat
40import qualified Language.PureScript as P
41import qualified Language.PureScript.CodeGen.JS as J
42import qualified Language.PureScript.CoreFn as CF
43import qualified Language.PureScript.Docs as Docs
45import Data.Char (isSpace)
46import Data.Maybe (mapMaybe, fromMaybe)
47import Data.List (isSuffixOf, sort, stripPrefix)
48import Data.Time.Clock (UTCTime())
50import qualified Data.Map as M
52import Control.Monad
53import Control.Monad.IO.Class (liftIO)
54import Control.Arrow ((>>>))
56import Control.Monad.Reader
57import Control.Monad.Writer.Strict
58import Control.Monad.Trans.Maybe
59import Control.Monad.Trans.Except
60import Control.Monad.Error.Class
62import System.Exit
63import System.Process
64import System.FilePath
65import System.Directory
66import System.IO.UTF8
67import qualified System.Info
68import qualified System.FilePath.Glob as Glob
70import Text.Parsec (ParseError)
72import TestsSetup
73import TestPscPublish
74import qualified TestDocs
76modulesDir :: FilePath
77modulesDir = ".test_modules" </> "node_modules"
79makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
80makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
81 { P.getInputTimestamp = getInputTimestamp
82 , P.getOutputTimestamp = getOutputTimestamp
83 }
84 where
85 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
86 getInputTimestamp mn
87 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
88 | otherwise = return (Left P.RebuildAlways)
89 where
90 isSupportModule = flip elem supportModules
92 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
93 getOutputTimestamp mn = do
94 let filePath = modulesDir </> P.runModuleName mn
95 exists <- liftIO $ doesDirectoryExist filePath
96 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
98readInput :: [FilePath] -> IO [(FilePath, String)]
99readInput inputFiles = forM inputFiles $ \inputFile -> do
100 text <- readUTF8File inputFile
101 return (inputFile, text)
103type TestM = WriterT [(FilePath, String)] IO
105runTest :: P.Make a -> IO (Either P.MultipleErrors a)
106runTest = fmap fst . P.runMake P.defaultOptions
108compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
109compile inputFiles foreigns = runTest $ do
110 fs <- liftIO $ readInput inputFiles
111 ms <- P.parseModulesFromFiles id fs
112 P.make (makeActions foreigns) (map snd ms)
114assert :: [FilePath] ->
115 M.Map P.ModuleName FilePath ->
116 (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
117 TestM ()
118assert inputFiles foreigns f = do
119 e <- liftIO $ compile inputFiles foreigns
120 maybeErr <- liftIO $ f e
121 case maybeErr of
122 Just err -> tell [(last inputFiles, err)]
123 Nothing -> return ()
125assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
126assertCompiles inputFiles foreigns = do
127 liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
128 assert inputFiles foreigns $ \e ->
129 case e of
130 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
131 Right _ -> do
132 process <- findNodeProcess
133 let entryPoint = modulesDir </> "index.js"
134 writeFile entryPoint "require('Main').main()"
135 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
136 case result of
137 Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
138 Just (ExitFailure _, _, err) -> return $ Just err
139 Nothing -> return $ Just "Couldn't find node.js executable"
141assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
142assertDoesNotCompile inputFiles foreigns = do
143 let testFile = last inputFiles
144 liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
145 shouldFailWith <- getShouldFailWith testFile
146 assert inputFiles foreigns $ \e ->
147 case e of
148 Left errs -> do
149 putStrLn (P.prettyPrintMultipleErrors False errs)
150 return $ if null shouldFailWith
151 then Just $ "shouldFailWith declaration is missing (errors were: "
152 ++ show (map P.errorCode (P.runMultipleErrors errs))
153 ++ ")"
154 else checkShouldFailWith shouldFailWith errs
155 Right _ ->
156 return $ Just "Should not have compiled"
158 where
159 getShouldFailWith =
160 readUTF8File
161 >>> liftIO
162 >>> fmap ( lines
163 >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
164 >>> map trim
165 )
167 checkShouldFailWith expected errs =
168 let actual = map P.errorCode $ P.runMultipleErrors errs
169 in if sort expected == sort actual
170 then Nothing
171 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
173 trim =
174 dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
176main :: IO ()
177main = do
178 heading "Main compiler test suite"
179 testCompiler
180 heading "Documentation test suite"
181 TestDocs.main
182 -- heading "psc-publish test suite"
183 -- testPscPublish
185 where
186 heading msg = do
187 putStrLn ""
188 putStrLn $ replicate 79 '#'
189 putStrLn $ "# " ++ msg
190 putStrLn $ replicate 79 '#'
191 putStrLn ""
193testCompiler :: IO ()
194testCompiler = do
195 fetchSupportCode
196 cwd <- getCurrentDirectory
198 let supportDir = cwd </> "tests" </> "support" </> "flattened"
199 let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir
201 supportPurs <- supportFiles "purs"
202 supportJS <- supportFiles "js"
204 foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
205 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
207 let passing = cwd </> "examples" </> "passing"
208 passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
209 let failing = cwd </> "examples" </> "failing"
210 failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
212 failures <- execWriterT $ do
213 forM_ passingTestCases $ \inputFile ->
214 assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
215 forM_ failingTestCases $ \inputFile ->
216 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
218 if null failures
219 then pure ()
220 else do
221 putStrLn "Failures:"
222 forM_ failures $ \(fp, err) ->
223 let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
224 in putStrLn $ fp' ++ ": " ++ err
225 exitFailure
227testPscPublish :: IO ()
228testPscPublish = do
229 testPackage "tests/support/prelude"
232supportModules :: [String]
233supportModules =
234 [ "Control.Monad.Eff.Class"
235 , "Control.Monad.Eff.Console"
236 , "Control.Monad.Eff"
237 , "Control.Monad.Eff.Unsafe"
238 , "Control.Monad.ST"
239 , "Data.Function"
240 , "Prelude"
241 , "Test.Assert"
242 ]