Fix purescript#1297, reduce memory usage from WriterT

paf31 · paf31 · commit b3bb653dc63e · 2015-10-26T12:57:37.000-07:00
diff --git a/psc/Main.hs b/psc/Main.hs
@@ -71,15 +71,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 (map snd ms)
+      (e, warnings') <- runMake opts $ P.make makeActions (map snd ms)
+      when (P.nonEmpty warnings') $
+        hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
       case e of
         Left errs -> do
           hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
           exitFailure
-        Right (_, warnings') -> do
-          when (P.nonEmpty warnings') $
-            hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
-          exitSuccess
+        Right _ -> exitSuccess
 
 warnFileTypeNotFound :: String -> IO ()
 warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
@@ -254,7 +254,7 @@ modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
 -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
 -- options and ignores the warning messages.
 runMake :: P.Make a -> IO (Either P.MultipleErrors a)
-runMake mk = fmap (fmap fst) $ P.runMake P.defaultOptions mk
+runMake mk = fmap fst $ P.runMake P.defaultOptions mk
 
 makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a
 makeIO f io = do
diff --git a/purescript.cabal b/purescript.cabal
@@ -170,6 +170,7 @@ library
                      Language.PureScript.Publish.ErrorsWarnings
                      Language.PureScript.Publish.BoxesHelpers
 
+                     Control.Monad.Logger
                      Control.Monad.Unify
                      Control.Monad.Supply
                      Control.Monad.Supply.Class
diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs
@@ -0,0 +1,75 @@
+-----------------------------------------------------------------------------
+--
+-- Module      :  Control.Monad.Logger
+-- Author      :  Phil Freeman
+-- License     :  MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer  :  Phil Freeman <paf31@cantab.net>
+-- Stability   :  experimental
+-- Portability :
+--
+-- | A replacement for WriterT IO which uses mutable references.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Control.Monad.Logger where
+
+import Data.IORef
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative
+#endif
+import Control.Monad (ap)
+import Control.Monad.IO.Class
+import Control.Monad.Writer.Class
+import Control.Monad.Base (MonadBase(..))
+import Control.Monad.Trans.Control (MonadBaseControl(..))
+
+-- | A replacement for WriterT IO which uses mutable references.
+data Logger w a = Logger { runLogger :: IORef w -> IO a }
+
+-- | Run a Logger computation, starting with an empty log.
+runLogger' :: (Monoid w) => Logger w a -> IO (a, w)
+runLogger' l = do
+  r <- newIORef mempty
+  a <- runLogger l r
+  w <- readIORef r
+  return (a, w)
+
+instance Functor (Logger w) where
+  fmap f (Logger l) = Logger $ \r -> fmap f (l r)
+
+instance (Monoid w) => Applicative (Logger w) where
+  pure = Logger . const . pure
+  (<*>) = ap
+
+instance (Monoid w) => Monad (Logger w) where
+  return = pure
+  Logger l >>= f = Logger $ \r -> l r >>= \a -> runLogger (f a) r
+
+instance (Monoid w) => MonadIO (Logger w) where
+  liftIO = Logger . const
+
+instance (Monoid w) => MonadWriter w (Logger w) where
+  tell w = Logger $ \r -> modifyIORef' r (mappend w)
+  listen l = Logger $ \r -> do
+    (a, w) <- liftIO (runLogger' l)
+    modifyIORef' r (mappend w)
+    return (a, w)
+  pass l = Logger $ \r -> do
+    ((a, f), w) <- liftIO (runLogger' l)
+    modifyIORef' r (mappend (f w))
+    return a
+
+instance (Monoid w) => MonadBase IO (Logger w) where
+  liftBase = liftIO
+
+instance (Monoid w) => MonadBaseControl IO (Logger w) where
+  type StM (Logger w) a = a
+  liftBaseWith f = Logger $ \r -> liftBaseWith $ \q -> f (q . flip runLogger r)
+  restoreM = return
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -43,9 +43,10 @@ import Control.Applicative
 #endif
 import Control.Monad
 import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Trans.Except
 import Control.Monad.Reader
-import Control.Monad.Writer.Strict
+import Control.Monad.Logger
 import Control.Monad.Supply
 import Control.Monad.Base (MonadBase(..))
 import Control.Monad.Trans.Control (MonadBaseControl(..))
@@ -284,22 +285,22 @@ importPrim = addDefaultImport (ModuleName [ProperName C.prim])
 -- |
 -- A monad for running make actions
 --
-newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
+newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
   deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
 
 instance MonadBase IO Make where
   liftBase = liftIO
 
 instance MonadBaseControl IO Make where
-  type StM Make a = Either MultipleErrors (a, MultipleErrors)
+  type StM Make a = Either MultipleErrors a
   liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
   restoreM = Make . restoreM
 
 -- |
 -- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
 --
-runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
-runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
+runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
+runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
 
 makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
 makeIO f io = do
