summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorPhilFreeman <>2015-06-30 01:42:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-06-30 01:42:00 (GMT)
commite2d6ce02076b1c8f647b25efe19b89f61e02bbaf (patch)
treeb49066c9978408370e829708ce43b327c12f5a09 /tests
parent0ead6173f8d2b592406633546f30530ae0d93aff (diff)
version 0.7.0.00.7.0.0
Diffstat (limited to 'tests')
-rw-r--r--tests/Main.hs204
1 files changed, 141 insertions, 63 deletions
diff --git a/tests/Main.hs b/tests/Main.hs
index e7ac794..4bf2edd 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -12,97 +12,175 @@
--
-----------------------------------------------------------------------------
-{-# LANGUAGE DataKinds, DoAndIfThenElse #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
module Main (main) where
import qualified Language.PureScript as P
+import qualified Language.PureScript.CodeGen.JS as J
+import qualified Language.PureScript.CoreFn as CF
import Data.List (isSuffixOf)
import Data.Traversable (traverse)
+import Data.Time.Clock (UTCTime())
+
+import qualified Data.Map as M
+
import Control.Monad
-import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
-import Control.Monad.Reader (runReaderT)
+import Control.Monad.IO.Class (liftIO)
import Control.Applicative
+
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Except
+import Control.Monad.Error.Class
+
import System.Exit
import System.Process
-import System.FilePath (pathSeparator)
-import System.Directory (getCurrentDirectory, getTemporaryDirectory, getDirectoryContents, findExecutable)
+import System.FilePath
+import System.Directory
+
import Text.Parsec (ParseError)
+modulesDir :: FilePath
+modulesDir = ".test_modules" </> "node_modules"
+
+newtype Test a = Test { unTest :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
+
+runTest :: Test a -> IO (Either P.MultipleErrors a)
+runTest = runExceptT . fmap fst . runWriterT . flip runReaderT P.defaultOptions . unTest
+
+makeActions :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> P.MakeActions Test
+makeActions foreigns = P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
+ where
+ getInputTimestamp :: P.ModuleName -> Test (Either P.RebuildPolicy (Maybe UTCTime))
+ getInputTimestamp mn
+ | isPreludeModule (P.runModuleName mn) = return (Left P.RebuildNever)
+ | otherwise = return (Left P.RebuildAlways)
+ where
+ isPreludeModule = flip elem
+ [ "Prelude.Unsafe"
+ , "Prelude"
+ , "Data.Function"
+ , "Control.Monad.Eff"
+ , "Control.Monad.ST"
+ , "Debug.Trace"
+ , "Assert"
+ ]
+
+ getOutputTimestamp :: P.ModuleName -> Test (Maybe UTCTime)
+ getOutputTimestamp mn = do
+ let filePath = modulesDir </> P.runModuleName mn
+ exists <- liftIO $ doesDirectoryExist filePath
+ return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing)
+
+ readExterns :: P.ModuleName -> Test (FilePath, String)
+ readExterns mn = do
+ let filePath = modulesDir </> P.runModuleName mn </> "externs.purs"
+ (filePath, ) <$> readTextFile filePath
+
+ codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Test ()
+ codegen m _ nextVar exts = do
+ let mn = CF.moduleName m
+ foreignInclude <- case (CF.moduleName m `M.lookup` foreigns, CF.moduleForeign m) of
+ (Just _, []) -> error "Unnecessary foreign module"
+ (Just path, _) -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
+ (Nothing, []) -> return Nothing
+ (Nothing, _) -> error "Missing foreign module"
+ pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
+ let filePath = P.runModuleName $ CF.moduleName m
+ jsFile = modulesDir </> filePath </> "index.js"
+ externsFile = modulesDir </> filePath </> "externs.purs"
+ foreignFile = modulesDir </> filePath </> "foreign.js"
+ writeTextFile jsFile pjs
+ maybe (return ()) (writeTextFile foreignFile . snd) $ CF.moduleName m `M.lookup` foreigns
+ writeTextFile externsFile exts
+
+ readTextFile :: FilePath -> Test String
+ readTextFile path = liftIO $ readFile path
+
+ writeTextFile :: FilePath -> String -> Test ()
+ writeTextFile path text = liftIO $ do
+ createDirectoryIfMissing True (takeDirectory path)
+ writeFile path text
+
+ progress :: String -> Test ()
+ progress = liftIO . putStrLn
+
readInput :: [FilePath] -> IO [(FilePath, String)]
readInput inputFiles = forM inputFiles $ \inputFile -> do
text <- readFile inputFile
return (inputFile, text)
-loadPrelude :: Either String (String, String, P.Environment)
-loadPrelude =
- case P.parseModulesFromFiles id [("", P.prelude)] of
- Left parseError -> Left (show parseError)
- Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }
-
-compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))
-compile opts inputFiles = do
- modules <- P.parseModulesFromFiles id <$> readInput inputFiles
- case modules of
- Left parseError ->
- return (Left $ show parseError)
- Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts
-
-assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
-assert preludeExterns opts inputFile f = do
- e <- compile opts [preludeExterns, inputFile]
+compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment)
+compile inputFiles foreigns = runTest $ do
+ fs <- liftIO $ readInput inputFiles
+ ms <- P.parseModulesFromFiles id fs
+ P.make (makeActions foreigns) (map (\(k, v) -> (Right k, v)) ms)
+
+assert :: [FilePath] ->
+ M.Map P.ModuleName (FilePath, P.ForeignJS) ->
+ (Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
+ IO ()
+assert inputFiles foreigns f = do
+ e <- compile inputFiles foreigns
maybeErr <- f e
case maybeErr of
Just err -> putStrLn err >> exitFailure
Nothing -> return ()
-assertCompiles :: String -> FilePath -> FilePath -> IO ()
-assertCompiles preludeJs preludeExterns inputFile = do
- putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"
- let options = P.defaultCompileOptions
- { P.optionsMain = Just "Main"
- , P.optionsAdditional = P.CompileOptions "Tests" ["Main"] ["Main"]
- }
- assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do
- process <- findNodeProcess
- result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process
- case result of
- Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
- Just (ExitFailure _, _, err) -> return $ Just err
- Nothing -> return $ Just "Couldn't find node.js executable"
-
-assertDoesNotCompile :: FilePath -> FilePath -> IO ()
-assertDoesNotCompile preludeExterns inputFile = do
- putStrLn $ "Assert " ++ inputFile ++ " does not compile"
- assert preludeExterns (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) inputFile $ \e ->
+assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
+assertCompiles inputFiles foreigns = do
+ putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
+ assert inputFiles foreigns $ \e ->
+ case e of
+ Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs
+ Right _ -> do
+ process <- findNodeProcess
+ let entryPoint = modulesDir </> "index.js"
+ writeFile entryPoint "require('Main').main()"
+ result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process
+ case result of
+ Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
+ Just (ExitFailure _, _, err) -> return $ Just err
+ Nothing -> return $ Just "Couldn't find node.js executable"
+
+assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO ()
+assertDoesNotCompile inputFiles foreigns = do
+ putStrLn $ "Assert " ++ last inputFiles ++ " does not compile"
+ assert inputFiles foreigns $ \e ->
case e of
- Left err -> putStrLn err >> return Nothing
+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> return Nothing
Right _ -> return $ Just "Should not have compiled"
findNodeProcess :: IO (Maybe String)
findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
- where names = ["nodejs", "node"]
+ where
+ names = ["nodejs", "node"]
main :: IO ()
main = do
- putStrLn "Compiling Prelude"
- case loadPrelude of
- Left err -> putStrLn err >> exitFailure
- Right (preludeJs, exts, _) -> do
- tmp <- getTemporaryDirectory
- let preludeExterns = tmp ++ pathSeparator : "prelude.externs"
- writeFile preludeExterns exts
- putStrLn $ "Wrote " ++ preludeExterns
- cd <- getCurrentDirectory
- let examples = cd ++ pathSeparator : "examples"
- let passing = examples ++ pathSeparator : "passing"
- passingTestCases <- getDirectoryContents passing
- forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
- assertCompiles preludeJs preludeExterns (passing ++ pathSeparator : inputFile)
- let failing = examples ++ pathSeparator : "failing"
- failingTestCases <- getDirectoryContents failing
- forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
- assertDoesNotCompile preludeExterns (failing ++ pathSeparator : inputFile)
- exitSuccess
-
+ cwd <- getCurrentDirectory
+
+ let preludeDir = cwd </> "tests" </> "prelude"
+ preludePurs = preludeDir </> "Prelude.purs"
+ jsDir = preludeDir </> "js"
+ jsFiles <- map (jsDir </>) . filter (".js" `isSuffixOf`) <$> getDirectoryContents jsDir
+ foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f)
+ Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
+
+ let passing = cwd </> "examples" </> "passing"
+ passingTestCases <- getDirectoryContents passing
+ forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
+ assertCompiles [preludePurs, passing </> inputFile] foreigns
+ let failing = cwd </> "examples" </> "failing"
+ failingTestCases <- getDirectoryContents failing
+ forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
+ assertDoesNotCompile [preludePurs, failing </> inputFile] foreigns
+ exitSuccess