git.iko.soy/rowtype-yoga/purescript-native
on 24fdff2 help sign in
rowtype-yoga/purescript-native/tests/Main.hs
216 lines 7.4 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
72modulesDir :: FilePath
73modulesDir = ".test_modules" </> "node_modules"
75makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
76makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
77 { P.getInputTimestamp = getInputTimestamp
78 , P.getOutputTimestamp = getOutputTimestamp
79 }
80 where
81 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
82 getInputTimestamp mn
83 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
84 | otherwise = return (Left P.RebuildAlways)
85 where
86 isSupportModule = flip elem supportModules
88 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
89 getOutputTimestamp mn = do
90 let filePath = modulesDir </> P.runModuleName mn
91 exists <- liftIO $ doesDirectoryExist filePath
92 return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing)
94readInput :: [FilePath] -> IO [(FilePath, String)]
95readInput inputFiles = forM inputFiles $ \inputFile -> do
96 text <- readUTF8File inputFile
97 return (inputFile, text)
99type TestM = WriterT [(FilePath, String)] IO
101runTest :: P.Make a -> IO (Either P.MultipleErrors a)
102runTest = fmap fst . P.runMake P.defaultOptions
104compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
105compile inputFiles foreigns = runTest $ do
106 fs <- liftIO $ readInput inputFiles
107 ms <- P.parseModulesFromFiles id fs
108 P.make (makeActions foreigns) (map snd ms)
110assert :: [FilePath] ->
111 M.Map P.ModuleName FilePath ->
112 (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
113 TestM ()
114assert inputFiles foreigns f = do
115 e <- liftIO $ compile inputFiles foreigns
116 maybeErr <- liftIO $ f e
117 case maybeErr of
118 Just err -> tell [(last inputFiles, err)]
119 Nothing -> return ()
121assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
122assertCompiles inputFiles foreigns = do
123 liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
124 assert inputFiles foreigns $ \e ->
125 case e of
126 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
127 Right _ -> do
128 process <- findNodeProcess
129 let entryPoint = modulesDir </> "index.js"
130 writeFile entryPoint "require('Main').main()"
131 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
132 case result of
133 Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
134 Just (ExitFailure _, _, err) -> return $ Just err
135 Nothing -> return $ Just "Couldn't find node.js executable"
137assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
138assertDoesNotCompile inputFiles foreigns = do
139 let testFile = last inputFiles
140 liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
141 shouldFailWith <- getShouldFailWith testFile
142 assert inputFiles foreigns $ \e ->
143 case e of
144 Left errs -> do
145 putStrLn (P.prettyPrintMultipleErrors False errs)
146 return $ if null shouldFailWith
147 then Just $ "shouldFailWith declaration is missing (errors were: "
148 ++ show (map P.errorCode (P.runMultipleErrors errs))
149 ++ ")"
150 else checkShouldFailWith shouldFailWith errs
151 Right _ ->
152 return $ Just "Should not have compiled"
154 where
155 getShouldFailWith =
156 readUTF8File
157 >>> liftIO
158 >>> fmap ( lines
159 >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
160 >>> map trim
161 )
163 checkShouldFailWith expected errs =
164 let actual = map P.errorCode $ P.runMultipleErrors errs
165 in if sort expected == sort actual
166 then Nothing
167 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
169 trim =
170 dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
172main :: IO ()
173main = do
174 fetchSupportCode
175 cwd <- getCurrentDirectory
177 let supportDir = cwd </> "tests" </> "support" </> "flattened"
178 let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir
180 supportPurs <- supportFiles "purs"
181 supportJS <- supportFiles "js"
183 foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
184 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
186 let passing = cwd </> "examples" </> "passing"
187 passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
188 let failing = cwd </> "examples" </> "failing"
189 failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
191 failures <- execWriterT $ do
192 forM_ passingTestCases $ \inputFile ->
193 assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
194 forM_ failingTestCases $ \inputFile ->
195 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
197 if null failures
198 then exitSuccess
199 else do
200 putStrLn "Failures:"
201 forM_ failures $ \(fp, err) ->
202 let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
203 in putStrLn $ fp' ++ ": " ++ err
204 exitFailure
206supportModules :: [String]
207supportModules =
208 [ "Control.Monad.Eff.Class"
209 , "Control.Monad.Eff.Console"
210 , "Control.Monad.Eff"
211 , "Control.Monad.Eff.Unsafe"
212 , "Control.Monad.ST"
213 , "Data.Function"
214 , "Prelude"
215 , "Test.Assert"
216 ]