git.iko.soy/rowtype-yoga/purescript-native
on d09d430 help sign in
rowtype-yoga/purescript-native/tests/Main.hs
226 lines 7.6 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
34module Main (main) where
36import Prelude ()
37import Prelude.Compat
39import qualified Language.PureScript as P
40import qualified Language.PureScript.CodeGen.JS as J
41import qualified Language.PureScript.CoreFn as CF
43import Data.Char (isSpace)
44import Data.Maybe (mapMaybe, fromMaybe)
45import Data.List (isSuffixOf, sort, stripPrefix)
46import Data.Time.Clock (UTCTime())
48import qualified Data.Map as M
50import Control.Monad
51import Control.Monad.IO.Class (liftIO)
52import Control.Arrow ((>>>))
54import Control.Monad.Reader
55import Control.Monad.Writer.Strict
56import Control.Monad.Trans.Maybe
57import Control.Monad.Trans.Except
58import Control.Monad.Error.Class
60import System.Exit
61import System.Process
62import System.FilePath
63import System.Directory
64import System.IO.UTF8
65import qualified System.Info
66import qualified System.FilePath.Glob as Glob
68import Text.Parsec (ParseError)
70import TestsSetup
71import TestPscPublish
73modulesDir :: FilePath
74modulesDir = ".test_modules" </> "node_modules"
76makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
77makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
78 { P.getInputTimestamp = getInputTimestamp
79 , P.getOutputTimestamp = getOutputTimestamp
80 }
81 where
82 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
83 getInputTimestamp mn
84 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
85 | otherwise = return (Left P.RebuildAlways)
86 where
87 isSupportModule = flip elem supportModules
89 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
90 getOutputTimestamp mn = do
91 let filePath = modulesDir </> P.runModuleName mn
92 exists <- liftIO $ doesDirectoryExist filePath
93 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
95readInput :: [FilePath] -> IO [(FilePath, String)]
96readInput inputFiles = forM inputFiles $ \inputFile -> do
97 text <- readUTF8File inputFile
98 return (inputFile, text)
100type TestM = WriterT [(FilePath, String)] IO
102runTest :: P.Make a -> IO (Either P.MultipleErrors a)
103runTest = fmap fst . P.runMake P.defaultOptions
105compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
106compile inputFiles foreigns = runTest $ do
107 fs <- liftIO $ readInput inputFiles
108 ms <- P.parseModulesFromFiles id fs
109 P.make (makeActions foreigns) (map snd ms)
111assert :: [FilePath] ->
112 M.Map P.ModuleName FilePath ->
113 (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
114 TestM ()
115assert inputFiles foreigns f = do
116 e <- liftIO $ compile inputFiles foreigns
117 maybeErr <- liftIO $ f e
118 case maybeErr of
119 Just err -> tell [(last inputFiles, err)]
120 Nothing -> return ()
122assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
123assertCompiles inputFiles foreigns = do
124 liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
125 assert inputFiles foreigns $ \e ->
126 case e of
127 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
128 Right _ -> do
129 process <- findNodeProcess
130 let entryPoint = modulesDir </> "index.js"
131 writeFile entryPoint "require('Main').main()"
132 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
133 case result of
134 Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
135 Just (ExitFailure _, _, err) -> return $ Just err
136 Nothing -> return $ Just "Couldn't find node.js executable"
138assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
139assertDoesNotCompile inputFiles foreigns = do
140 let testFile = last inputFiles
141 liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
142 shouldFailWith <- getShouldFailWith testFile
143 assert inputFiles foreigns $ \e ->
144 case e of
145 Left errs -> do
146 putStrLn (P.prettyPrintMultipleErrors False errs)
147 return $ if null shouldFailWith
148 then Just $ "shouldFailWith declaration is missing (errors were: "
149 ++ show (map P.errorCode (P.runMultipleErrors errs))
150 ++ ")"
151 else checkShouldFailWith shouldFailWith errs
152 Right _ ->
153 return $ Just "Should not have compiled"
155 where
156 getShouldFailWith =
157 readUTF8File
158 >>> liftIO
159 >>> fmap ( lines
160 >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
161 >>> map trim
162 )
164 checkShouldFailWith expected errs =
165 let actual = map P.errorCode $ P.runMultipleErrors errs
166 in if sort expected == sort actual
167 then Nothing
168 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
170 trim =
171 dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
173main :: IO ()
174main = do
175 testCompiler
176 testPscPublish
178testCompiler :: IO ()
179testCompiler = do
180 fetchSupportCode
181 cwd <- getCurrentDirectory
183 let supportDir = cwd </> "tests" </> "support" </> "flattened"
184 let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir
186 supportPurs <- supportFiles "purs"
187 supportJS <- supportFiles "js"
189 foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
190 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
192 let passing = cwd </> "examples" </> "passing"
193 passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
194 let failing = cwd </> "examples" </> "failing"
195 failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
197 failures <- execWriterT $ do
198 forM_ passingTestCases $ \inputFile ->
199 assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
200 forM_ failingTestCases $ \inputFile ->
201 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
203 if null failures
204 then exitSuccess
205 else do
206 putStrLn "Failures:"
207 forM_ failures $ \(fp, err) ->
208 let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
209 in putStrLn $ fp' ++ ": " ++ err
210 exitFailure
212testPscPublish :: IO ()
213testPscPublish = do
214 testPackage "tests/support/prelude"
216supportModules :: [String]
217supportModules =
218 [ "Control.Monad.Eff.Class"
219 , "Control.Monad.Eff.Console"
220 , "Control.Monad.Eff"
221 , "Control.Monad.Eff.Unsafe"
222 , "Control.Monad.ST"
223 , "Data.Function"
224 , "Prelude"
225 , "Test.Assert"
226 ]