git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Reinstate test suite
7163760Phil Freeman
.gitignore+1
compare with golang
unifiedsplit
@@ -9,6 +9,7 @@ cabal.sandbox.config
9*.lksh*
9*.lksh*
10.virthualenv
10.virthualenv
11.psci_modules/
11.psci_modules/
12+.test_modules/
12bower_components/
13bower_components/
13tmp/
14tmp/
14.stack-work/
15.stack-work/
purescript.cabal+1−1
@@ -214,7 +214,7 @@ executable psc-hierarchy
214test-suite tests
214test-suite tests
215 build-depends: base >=4 && <5, containers -any, directory -any,
215 build-depends: base >=4 && <5, containers -any, directory -any,
216 filepath -any, mtl -any, parsec -any, purescript -any,
216 filepath -any, mtl -any, parsec -any, purescript -any,
217− transformers -any, process -any, transformers-compat -any
217+ transformers -any, process -any, transformers-compat -any, time -any
218 type: exitcode-stdio-1.0
218 type: exitcode-stdio-1.0
219 main-is: Main.hs
219 main-is: Main.hs
220 buildable: True
220 buildable: True
tests/Main.hs+126−58
@@ -12,75 +12,149 @@
12--
12--
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15−{-# LANGUAGE DataKinds, DoAndIfThenElse, TupleSections #-}
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE DoAndIfThenElse #-}
17+{-# LANGUAGE TupleSections #-}
18+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
19+{-# LANGUAGE FlexibleInstances #-}
16
20
17module Main (main) where
21module Main (main) where
18
22
19import qualified Language.PureScript as P
23import qualified Language.PureScript as P
24+import qualified Language.PureScript.CodeGen.JS as J
25+import qualified Language.PureScript.CoreFn as CF
20
26
21import Data.List (isSuffixOf)
27import Data.List (isSuffixOf)
22import Data.Traversable (traverse)
28import Data.Traversable (traverse)
29+import Data.Time.Clock (UTCTime())
23
30
24import qualified Data.Map as M
31import qualified Data.Map as M
25
32
26import Control.Monad
33import Control.Monad
27import Control.Monad.IO.Class (liftIO)
34import Control.Monad.IO.Class (liftIO)
28−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
29−import Control.Monad.Reader (runReaderT)
30−import Control.Monad.Writer (runWriterT)
31−import Control.Monad.Trans.Except (runExceptT)
32import Control.Applicative
35import Control.Applicative
33
36
37+import Control.Monad.Reader
38+import Control.Monad.Writer
39+import Control.Monad.Trans.Maybe
40+import Control.Monad.Trans.Except
41+import Control.Monad.Error.Class
42+
34import System.Exit
43import System.Exit
35import System.Process
44import System.Process
36−import System.FilePath ((</>))
45+import System.FilePath
37−import System.Directory (getCurrentDirectory, getTemporaryDirectory, getDirectoryContents, findExecutable)
46+import System.Directory
38
47
39import Text.Parsec (ParseError)
48import Text.Parsec (ParseError)
40
49
50+modulesDir :: FilePath
51+modulesDir = ".test_modules" </> "node_modules"
52+
53+newtype Test a = Test { unTest :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
54+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
55+
56+runTest :: Test a -> IO (Either P.MultipleErrors a)
57+runTest = runExceptT . fmap fst . runWriterT . flip runReaderT P.defaultOptions . unTest
58+
59+makeActions :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> P.MakeActions Test
60+makeActions foreigns = P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
61+ where
62+ getInputTimestamp :: P.ModuleName -> Test (Either P.RebuildPolicy (Maybe UTCTime))
63+ getInputTimestamp mn
64+ | isPreludeModule (P.runModuleName mn) = return (Left P.RebuildNever)
65+ | otherwise = return (Left P.RebuildAlways)
66+ where
67+ isPreludeModule = flip elem
68+ [ "Prelude.Unsafe"
69+ , "Prelude"
70+ , "Data.Function"
71+ , "Control.Monad.Eff"
72+ , "Control.Monad.ST"
73+ , "Debug.Trace"
74+ , "Assert"
75+ ]
76+
77+ getOutputTimestamp :: P.ModuleName -> Test (Maybe UTCTime)
78+ getOutputTimestamp mn = do
79+ let filePath = modulesDir </> P.runModuleName mn
80+ exists <- liftIO $ doesDirectoryExist filePath
81+ return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing)
82+
83+ readExterns :: P.ModuleName -> Test (FilePath, String)
84+ readExterns mn = do
85+ let filePath = modulesDir </> P.runModuleName mn </> "externs.purs"
86+ (filePath, ) <$> readTextFile filePath
87+
88+ codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Test ()
89+ codegen m _ nextVar exts = do
90+ let mn = CF.moduleName m
91+ foreignInclude <- case (CF.moduleName m `M.lookup` foreigns, CF.moduleForeign m) of
92+ (Just _, []) -> error "Unnecessary foreign module"
93+ (Just path, _) -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
94+ (Nothing, []) -> return Nothing
95+ (Nothing, _) -> error "Missing foreign module"
96+ pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
97+ let filePath = P.runModuleName $ CF.moduleName m
98+ jsFile = modulesDir </> filePath </> "index.js"
99+ externsFile = modulesDir </> filePath </> "externs.purs"
100+ foreignFile = modulesDir </> filePath </> "foreign.js"
101+ writeTextFile jsFile pjs
102+ maybe (return ()) (writeTextFile foreignFile . snd) $ CF.moduleName m `M.lookup` foreigns
103+ writeTextFile externsFile exts
104+
105+ readTextFile :: FilePath -> Test String
106+ readTextFile path = liftIO $ readFile path
107+
108+ writeTextFile :: FilePath -> String -> Test ()
109+ writeTextFile path text = liftIO $ do
110+ createDirectoryIfMissing True (takeDirectory path)
111+ writeFile path text
112+
113+ progress :: String -> Test ()
114+ progress = liftIO . putStrLn
115+
41readInput :: [FilePath] -> IO [(FilePath, String)]
116readInput :: [FilePath] -> IO [(FilePath, String)]
42readInput inputFiles = forM inputFiles $ \inputFile -> do
117readInput inputFiles = forM inputFiles $ \inputFile -> do
43 text <- readFile inputFile
118 text <- readFile inputFile
44 return (inputFile, text)
119 return (inputFile, text)
45
120
46−loadPrelude :: [(FilePath, String)] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> Either P.MultipleErrors (String, String, P.Environment)
47−loadPrelude fs foreigns = do
48− ms <- P.parseModulesFromFiles id fs
49− fmap fst . runWriterT $ runReaderT (P.compileJS (map snd ms) foreigns []) (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] })
50−
51−compile :: P.Options P.Compile -> [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors (String, String, P.Environment))
121+compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment)
52−compile opts inputFiles foreigns = runExceptT . fmap fst . runWriterT . flip runReaderT opts $ do
122+compile inputFiles foreigns = runTest $ do
53 fs <- liftIO $ readInput inputFiles
123 fs <- liftIO $ readInput inputFiles
54 ms <- P.parseModulesFromFiles id fs
124 ms <- P.parseModulesFromFiles id fs
55− P.compileJS (map snd ms) foreigns []
125+ P.make (makeActions foreigns) (map (\(k, v) -> (Right k, v)) ms)
56−
126+
127+assert :: [FilePath] ->
128+ M.Map P.ModuleName (FilePath, P.ForeignJS) ->
57−assert :: FilePath -> P.Options P.Compile -> FilePath -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> (Either P.MultipleErrors (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
129+ (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
130+ IO ()
58−assert preludeExterns opts inputFile foreigns f = do
131+assert inputFiles foreigns f = do
59− e <- compile opts [preludeExterns, inputFile] foreigns
132+ e <- compile inputFiles foreigns
60 maybeErr <- f e
133 maybeErr <- f e
61 case maybeErr of
134 case maybeErr of
62 Just err -> putStrLn err >> exitFailure
135 Just err -> putStrLn err >> exitFailure
63 Nothing -> return ()
136 Nothing -> return ()
64
137
65−assertCompiles :: String -> FilePath -> FilePath -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
138+assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
66−assertCompiles preludeJs preludeExterns inputFile foreigns = do
139+assertCompiles inputFiles foreigns = do
67− putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"
140+ putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
68− let options = P.defaultCompileOptions
141+ assert inputFiles foreigns $ \e ->
69− { P.optionsMain = Just "Main"
142+ case e of
70− , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]
71− }
72− assert preludeExterns options inputFile foreigns $ either (return . Just . P.prettyPrintMultipleErrors False) $ \(js, _, _) -> do
143+ Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
144+ Right _ -> do
73− process <- findNodeProcess
145+ process <- findNodeProcess
146+ let entryPoint = modulesDir </> "index.js"
147+ writeFile entryPoint "require('Main').main()"
74− result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process
148+ result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
75− case result of
149+ case result of
76− Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
150+ Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
77− Just (ExitFailure _, _, err) -> return $ Just err
151+ Just (ExitFailure _, _, err) -> return $ Just err
78− Nothing -> return $ Just "Couldn't find node.js executable"
152+ Nothing -> return $ Just "Couldn't find node.js executable"
79−
153+
80−assertDoesNotCompile :: FilePath -> FilePath -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
154+assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
81−assertDoesNotCompile preludeExterns inputFile foreigns = do
155+assertDoesNotCompile inputFiles foreigns = do
82− putStrLn $ "Assert " ++ inputFile ++ " does not compile"
156+ putStrLn $ "Assert " ++ last inputFiles ++ " does not compile"
83− assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile foreigns $ \e ->
157+ assert inputFiles foreigns $ \e ->
84 case e of
158 case e of
85 Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing
159 Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing
86 Right _ -> return $ Just "Should not have compiled"
160 Right _ -> return $ Just "Should not have compiled"
@@ -93,26 +167,20 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
93main :: IO ()
167main :: IO ()
94main = do
168main = do
95 cwd <- getCurrentDirectory
169 cwd <- getCurrentDirectory
170+
96− let preludeDir = cwd </> "tests" </> "prelude"
171+ let preludeDir = cwd </> "tests" </> "prelude"
97− jsDir = preludeDir </> "js"
98− prelude <- readInput [preludeDir </> "Prelude.purs"]
172+ preludePurs = preludeDir </> "Prelude.purs"
173+ jsDir = preludeDir </> "js"
99 jsFiles <- map (jsDir </>) . filter (".js" `isSuffixOf`) <$> getDirectoryContents jsDir
174 jsFiles <- map (jsDir </>) . filter (".js" `isSuffixOf`) <$> getDirectoryContents jsDir
100 foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f)
175 foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f)
101 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
176 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
102− putStrLn "Compiling Prelude"
177+
103− case loadPrelude prelude foreigns of
104− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
105− Right (preludeJs, exts, _) -> do
106− tmp <- getTemporaryDirectory
107− let preludeExterns = tmp </> "prelude.externs"
108− writeFile preludeExterns exts
109− putStrLn $ "Wrote " ++ preludeExterns
110− let passing = cwd </> "examples" </> "passing"
178+ let passing = cwd </> "examples" </> "passing"
111− passingTestCases <- getDirectoryContents passing
179+ passingTestCases <- getDirectoryContents passing
112− forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
180+ forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
113− assertCompiles preludeJs preludeExterns (passing </> inputFile) foreigns
181+ assertCompiles [preludePurs, passing </> inputFile] foreigns
114− let failing = cwd </> "examples" </> "failing"
182+ let failing = cwd </> "examples" </> "failing"
115− failingTestCases <- getDirectoryContents failing
183+ failingTestCases <- getDirectoryContents failing
116− forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
184+ forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
117− assertDoesNotCompile preludeExterns (failing </> inputFile) foreigns
185+ assertDoesNotCompile [preludePurs, failing </> inputFile] foreigns
118− exitSuccess
186+ exitSuccess