Merge pull request purescript#1325 from purescript/1276

paf31 · paf31 · commit fde48d73af0c · 2015-08-02T14:41:41.000-07:00
Fix purescript#1276
diff --git a/psc/Main.hs b/psc/Main.hs
@@ -68,14 +68,14 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d
         hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
       let filePathMap = M.fromList $ map (\(fp, P.Module _ mn _ _) -> (mn, fp)) ms
           makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix
-      e <- runMake opts $ P.make makeActions ms
+      e <- runMake opts $ P.make makeActions (map snd ms)
       case e of
         Left errs -> do
           hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
           exitFailure
         Right (_, warnings') -> do
           when (P.nonEmpty warnings') $
-            putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
+            hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
           exitSuccess
 
 readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
@@ -21,7 +21,7 @@
 module PSCi where
 
 import Data.Foldable (traverse_)
-import Data.List (intercalate, nub, sort, isPrefixOf)
+import Data.List (intercalate, nub, sort)
 import Data.Traversable (traverse)
 import Data.Tuple (swap)
 import Data.Version (showVersion)
@@ -259,11 +259,11 @@ makeIO f io = do
   either (throwError . P.singleError . f) return e
 
 make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment
-make PSCiState{..} ms = P.make actions' (psciLoadedModules ++ ms)
+make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms))
     where
     filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
     actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
-    actions' = actions { P.progress = \s -> unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s }
+    actions' = actions { P.progress = const (return ()) }
 
 -- |
 -- Takes a value declaration and evaluates it with the current state.
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -136,10 +136,10 @@ data RebuildPolicy
 --
 make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
      => MakeActions m
-     -> [(Either RebuildPolicy FilePath, Module)]
+     -> [Module]
      -> m Environment
 make MakeActions{..} ms = do
-  (sorted, graph) <- sortModules $ map (importPrim . snd) ms
+  (sorted, graph) <- sortModules $ map importPrim ms
   mapM_ lint sorted
   toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
     inputTimestamp <- getInputTimestamp moduleName'
@@ -282,6 +282,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
         foreignFile = outputDir </> filePath </> "foreign.js"
         prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
         js = unlines $ map ("// " ++) prefix ++ [pjs]
+    verboseErrorsEnabled <- asks optionsVerboseErrors
+    when verboseErrorsEnabled $ progress $ "Writing " ++ jsFile
     writeTextFile jsFile js
     maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
     writeTextFile externsFile exts
@@ -295,16 +297,11 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     traverse (const $ getModificationTime path) $ guard exists
 
   readTextFile :: FilePath -> Make String
-  readTextFile path = do
-    verboseErrorsEnabled <- asks optionsVerboseErrors
-    makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ do
-      when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
-      readFile path
+  readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ readFile path
 
   writeTextFile :: FilePath -> String -> Make ()
   writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
     mkdirp path
-    putStrLn $ "Writing " ++ path
     writeFile path text
     where
     mkdirp :: FilePath -> IO ()
diff --git a/tests/Main.hs b/tests/Main.hs
@@ -115,7 +115,7 @@ compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Eithe
 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)
+  P.make (makeActions foreigns) (map snd ms)
 
 assert :: [FilePath] ->
           M.Map P.ModuleName (FilePath, P.ForeignJS) ->
