git.iko.soy/rowtype-yoga/purescript-native
on 00a4705 help sign in
rowtype-yoga/purescript-native/tests/Main.hs
221 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 GeneralizedNewtypeDeriving #-}
18{-# LANGUAGE FlexibleInstances #-}
19{-# LANGUAGE CPP #-}
21-- Failing tests can specify the kind of error that should be thrown with a
22-- @shouldFailWith declaration. For example:
23--
24-- "-- @shouldFailWith TypesDoNotUnify"
25--
26-- will cause the test to fail unless that module fails to compile with exactly
27-- one TypesDoNotUnify error.
28--
29-- If a module is expected to produce multiple type errors, then use multiple
30-- @shouldFailWith lines; for example:
31--
32-- -- @shouldFailWith TypesDoNotUnify
33-- -- @shouldFailWith TypesDoNotUnify
34-- -- @shouldFailWith TransitiveExportError
36module Main (main) where
38import qualified Language.PureScript as P
39import qualified Language.PureScript.CodeGen.JS as J
40import qualified Language.PureScript.CoreFn as CF
42import Data.Char (isSpace)
43import Data.Maybe (mapMaybe, fromMaybe)
44import Data.List (isSuffixOf, sort, stripPrefix)
45#if __GLASGOW_HASKELL__ < 710
46import Data.Traversable (traverse)
47#endif
48import Data.Time.Clock (UTCTime())
50import qualified Data.Map as M
52import Control.Monad
53import Control.Monad.IO.Class (liftIO)
54#if __GLASGOW_HASKELL__ < 710
55import Control.Applicative
56#endif
57import Control.Arrow ((>>>))
59import Control.Monad.Reader
60import Control.Monad.Writer.Strict
61import Control.Monad.Trans.Maybe
62import Control.Monad.Trans.Except
63import Control.Monad.Error.Class
65import System.Exit
66import System.Process
67import System.FilePath
68import System.Directory
69import System.IO.UTF8
70import qualified System.Info
71import qualified System.FilePath.Glob as Glob
73import Text.Parsec (ParseError)
75import TestsSetup
77modulesDir :: FilePath
78modulesDir = ".test_modules" </> "node_modules"
80makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
81makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input file map was read.") foreigns False)
82 { P.getInputTimestamp = getInputTimestamp
83 , P.getOutputTimestamp = getOutputTimestamp
84 }
85 where
86 getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
87 getInputTimestamp mn
88 | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
89 | otherwise = return (Left P.RebuildAlways)
90 where
91 isSupportModule = flip elem supportModules
93 getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
94 getOutputTimestamp mn = do
95 let filePath = modulesDir </> P.runModuleName mn
96 exists <- liftIO $ doesDirectoryExist filePath
97 return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing)
99readInput :: [FilePath] -> IO [(FilePath, String)]
100readInput inputFiles = forM inputFiles $ \inputFile -> do
101 text <- readUTF8File inputFile
102 return (inputFile, text)
104type TestM = WriterT [(FilePath, String)] IO
106runTest :: P.Make a -> IO (Either P.MultipleErrors a)
107runTest = fmap (fmap fst) . P.runMake P.defaultOptions
109compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
110compile inputFiles foreigns = runTest $ do
111 fs <- liftIO $ readInput inputFiles
112 ms <- P.parseModulesFromFiles id fs
113 P.make (makeActions foreigns) (map snd ms)
115assert :: [FilePath] ->
116 M.Map P.ModuleName FilePath ->
117 (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
118 TestM ()
119assert inputFiles foreigns f = do
120 e <- liftIO $ compile inputFiles foreigns
121 maybeErr <- liftIO $ f e
122 case maybeErr of
123 Just err -> tell [(last inputFiles, err)]
124 Nothing -> return ()
126assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
127assertCompiles inputFiles foreigns = do
128 liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
129 assert inputFiles foreigns $ \e ->
130 case e of
131 Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
132 Right _ -> do
133 process <- findNodeProcess
134 let entryPoint = modulesDir </> "index.js"
135 writeFile entryPoint "require('Main').main()"
136 result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
137 case result of
138 Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
139 Just (ExitFailure _, _, err) -> return $ Just err
140 Nothing -> return $ Just "Couldn't find node.js executable"
142assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
143assertDoesNotCompile inputFiles foreigns = do
144 let testFile = last inputFiles
145 liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
146 shouldFailWith <- getShouldFailWith testFile
147 assert inputFiles foreigns $ \e ->
148 case e of
149 Left errs -> do
150 putStrLn (P.prettyPrintMultipleErrors False errs)
151 return $ if null shouldFailWith
152 then Just $ "shouldFailWith declaration is missing (errors were: "
153 ++ show (map P.errorCode (P.runMultipleErrors errs))
154 ++ ")"
155 else checkShouldFailWith shouldFailWith errs
156 Right _ ->
157 return $ Just "Should not have compiled"
159 where
160 getShouldFailWith =
161 readUTF8File
162 >>> liftIO
163 >>> fmap ( lines
164 >>> mapMaybe (stripPrefix "-- @shouldFailWith ")
165 >>> map trim
166 )
168 checkShouldFailWith expected errs =
169 let actual = map P.errorCode $ P.runMultipleErrors errs
170 in if sort expected == sort actual
171 then Nothing
172 else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual
174 trim =
175 dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
177main :: IO ()
178main = do
179 fetchSupportCode
180 cwd <- getCurrentDirectory
182 let supportDir = cwd </> "tests" </> "support" </> "flattened"
183 let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir
185 supportPurs <- supportFiles "purs"
186 supportJS <- supportFiles "js"
188 foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)
189 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
191 let passing = cwd </> "examples" </> "passing"
192 passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing
193 let failing = cwd </> "examples" </> "failing"
194 failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
196 failures <- execWriterT $ do
197 forM_ passingTestCases $ \inputFile ->
198 assertCompiles (supportPurs ++ [passing </> inputFile]) foreigns
199 forM_ failingTestCases $ \inputFile ->
200 assertDoesNotCompile (supportPurs ++ [failing </> inputFile]) foreigns
202 if null failures
203 then exitSuccess
204 else do
205 putStrLn "Failures:"
206 forM_ failures $ \(fp, err) ->
207 let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp
208 in putStrLn $ fp' ++ ": " ++ err
209 exitFailure
211supportModules :: [String]
212supportModules =
213 [ "Control.Monad.Eff.Class"
214 , "Control.Monad.Eff.Console"
215 , "Control.Monad.Eff"
216 , "Control.Monad.Eff.Unsafe"
217 , "Control.Monad.ST"
218 , "Data.Function"
219 , "Prelude"
220 , "Test.Assert"
221 ]