@@ -12,75 +12,149 @@
1212--
1313-----------------------------------------------------------------------------
1414
15−{-# LANGUAGE DataKinds, DoAndIfThenElse, TupleSections #-}
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE DoAndIfThenElse #-}
17+{-# LANGUAGE TupleSections #-}
18+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
19+{-# LANGUAGE FlexibleInstances #-}
1620
1721module Main (main) where
1822
1923import qualified Language.PureScript as P
24+import qualified Language.PureScript.CodeGen.JS as J
25+import qualified Language.PureScript.CoreFn as CF
2026
2127import Data.List (isSuffixOf)
2228import Data.Traversable (traverse)
29+import Data.Time.Clock (UTCTime())
2330
2431import qualified Data.Map as M
2532
2633import Control.Monad
2734import 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)
3235import Control.Applicative
3336
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+
3443import System.Exit
3544import System.Process
36−import System.FilePath ((</>))
37−import System.Directory (getCurrentDirectory, getTemporaryDirectory, getDirectoryContents, findExecutable)
45+import System.FilePath
46+import System.Directory
3847
3948import Text.Parsec (ParseError)
4049
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+
41116readInput :: [FilePath] -> IO [(FilePath, String)]
42117readInput inputFiles = forM inputFiles $ \inputFile -> do
43118 text <- readFile inputFile
44119 return (inputFile, text)
45120
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))
52−compile opts inputFiles foreigns = runExceptT . fmap fst . runWriterT . flip runReaderT opts $ do
121+compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment)
122+compile inputFiles foreigns = runTest $ do
53123 fs <- liftIO $ readInput inputFiles
54124 ms <- P.parseModulesFromFiles id fs
55− P.compileJS (map snd ms) foreigns []
56−
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 ()
58−assert preludeExterns opts inputFile foreigns f = do
59− e <- compile opts [preludeExterns, inputFile] foreigns
125+ P.make (makeActions foreigns) (map (\(k, v) -> (Right k, v)) ms)
126+
127+assert :: [FilePath] ->
128+ M.Map P.ModuleName (FilePath, P.ForeignJS) ->
129+ (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
130+ IO ()
131+assert inputFiles foreigns f = do
132+ e <- compile inputFiles foreigns
60133 maybeErr <- f e
61134 case maybeErr of
62135 Just err -> putStrLn err >> exitFailure
63136 Nothing -> return ()
64137
65−assertCompiles :: String -> FilePath -> FilePath -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
66−assertCompiles preludeJs preludeExterns inputFile foreigns = do
67− putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"
68− let options = P.defaultCompileOptions
69− { P.optionsMain = Just "Main"
70− , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]
71− }
72− assert preludeExterns options inputFile foreigns $ either (return . Just . P.prettyPrintMultipleErrors False) $ \(js, _, _) -> do
73− process <- findNodeProcess
74− result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process
75− case result of
76− Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
77− Just (ExitFailure _, _, err) -> return $ Just err
78− Nothing -> return $ Just "Couldn't find node.js executable"
79−
80−assertDoesNotCompile :: FilePath -> FilePath -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
81−assertDoesNotCompile preludeExterns inputFile foreigns = do
82− putStrLn $ "Assert " ++ inputFile ++ " does not compile"
83− assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile foreigns $ \e ->
138+assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
139+assertCompiles inputFiles foreigns = do
140+ putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
141+ assert inputFiles foreigns $ \e ->
142+ case e of
143+ Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
144+ Right _ -> do
145+ process <- findNodeProcess
146+ let entryPoint = modulesDir </> "index.js"
147+ writeFile entryPoint "require('Main').main()"
148+ result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
149+ case result of
150+ Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
151+ Just (ExitFailure _, _, err) -> return $ Just err
152+ Nothing -> return $ Just "Couldn't find node.js executable"
153+
154+assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
155+assertDoesNotCompile inputFiles foreigns = do
156+ putStrLn $ "Assert " ++ last inputFiles ++ " does not compile"
157+ assert inputFiles foreigns $ \e ->
84158 case e of
85159 Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing
86160 Right _ -> return $ Just "Should not have compiled"
@@ -93,26 +167,20 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
93167main :: IO ()
94168main = do
95169 cwd <- getCurrentDirectory
96− let preludeDir = cwd </> "tests" </> "prelude"
97− jsDir = preludeDir </> "js"
98− prelude <- readInput [preludeDir </> "Prelude.purs"]
170+
171+ let preludeDir = cwd </> "tests" </> "prelude"
172+ preludePurs = preludeDir </> "Prelude.purs"
173+ jsDir = preludeDir </> "js"
99174 jsFiles <- map (jsDir </>) . filter (".js" `isSuffixOf`) <$> getDirectoryContents jsDir
100175 foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f)
101176 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
102− putStrLn "Compiling Prelude"
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"
111− passingTestCases <- getDirectoryContents passing
112− forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
113− assertCompiles preludeJs preludeExterns (passing </> inputFile) foreigns
114− let failing = cwd </> "examples" </> "failing"
115− failingTestCases <- getDirectoryContents failing
116− forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
117− assertDoesNotCompile preludeExterns (failing </> inputFile) foreigns
118− exitSuccess
177+
178+ let passing = cwd </> "examples" </> "passing"
179+ passingTestCases <- getDirectoryContents passing
180+ forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
181+ assertCompiles [preludePurs, passing </> inputFile] foreigns
182+ let failing = cwd </> "examples" </> "failing"
183+ failingTestCases <- getDirectoryContents failing
184+ forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
185+ assertDoesNotCompile [preludePurs, failing </> inputFile] foreigns
186+ exitSuccess