version 0.7.0.00.7.0.0

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