From 457078bd988cb672b79774639e622edbdfd8868e Mon Sep 17 00:00:00 2001
From: Daniel Stiner <daniel.stiner+github@gmail.com>
Date: Sun, 18 Feb 2018 19:13:46 -0800
Subject: [PATCH] Avoid sequencing entire sources list into memory (#30)

* Add RunResult type
* Back to having a single Counduit pipeline
* Use custom bimapM as bitraversable is not available on older GHC versions
---
 app/ExitCode.hs | 13 +++++------
 app/Main.hs     | 59 +++++++++++++++++++++++++------------------------
 app/Types.hs    | 15 +++++++++++++
 3 files changed, 51 insertions(+), 36 deletions(-)

diff --git a/app/ExitCode.hs b/app/ExitCode.hs
index f3baa22..910811b 100644
--- a/app/ExitCode.hs
+++ b/app/ExitCode.hs
@@ -16,13 +16,12 @@ import Text.PrettyPrint.ANSI.Leijen
 -- should exit with failure if any format differences were found. Otherwise
 -- assume we are being run in a context where non-zero exit indicates
 -- failure of the tool to operate properly.
-exitCode :: Action -> Bool -> ExitCode
-exitCode action formattedCodeDiffers =
-  if formattedCodeDiffers && failOnDifferences
-    then ExitFailure formattedCodeDiffersFailureCode
-    else ExitSuccess
-  where
-    failOnDifferences = action == PrintDiffs
+exitCode :: Action -> RunResult -> ExitCode
+exitCode _ NoDifferences = ExitSuccess
+exitCode PrintDiffs HadDifferences = ExitFailure formattedCodeDiffersFailureCode
+exitCode _ HadDifferences = ExitSuccess
+exitCode _ SourceParseFailure = ExitFailure sourceParseFailureCode
+exitCode _ OperationalFailure = ExitFailure operationalFailureCode
 
 helpDoc :: Doc
 helpDoc =
diff --git a/app/Main.hs b/app/Main.hs
index 98c2928..4e96685 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -16,38 +16,44 @@ import Conduit
 import Options.Applicative.Extra          as OptApp
 import System.Directory
 import System.Exit
+import System.IO
 
 main :: IO ()
 main = do
   options <- execParser Options.parser
-  changes <- run options
-  case changes of
-    Left err -> print err >> exitWith (ExitFailure sourceParseFailureCode)
-    Right changes' -> do
-      formattedCodeDiffers <-
-        runConduit $
-        yieldMany changes' .| mapMC (Actions.act options) .|
-        anyC' (\(Formatted _ source result) -> wasReformatted source result)
-      exitWith $ exitCode (optAction options) formattedCodeDiffers
+  result <- run options
+  exitWith $ exitCode (optAction options) result
 
-run :: Options -> IO (Either FormatError [Formatted])
-run options = do
-  changesE <-
-    runConduit $ sources .| mapMC readSource .| mapMC formatSource .| sinkList
-  return $ sequence changesE
+run :: Options -> IO RunResult
+run opt =
+  runConduit $
+  sources opt .| mapMC readSource .| mapMC formatSource .| mapMC doAction .|
+  foldMapMC toRunResult
   where
-    paths = do
-      let explicitPaths = optPaths options
+    formatSource source = do
+      formatter <- defaultFormatter
+      return $ applyFormatter formatter source
+    doAction :: FormatResult -> IO FormatResult
+    doAction = bimapM return (Actions.act opt)
+    toRunResult :: FormatResult -> IO RunResult
+    toRunResult (Left err) = do
+      hPrint stderr (show err)
+      return SourceParseFailure
+    toRunResult (Right (Formatted _ source result)) =
+      if wasReformatted source result
+        then return HadDifferences
+        else return NoDifferences
+
+sources :: Options -> Source IO SourceFile
+sources opt = lift paths >>= mapM_ sourcesFromPath
+  where
+    explicitPaths = optPaths opt
+    paths =
       if null explicitPaths
         then do
           currentPath <- getCurrentDirectory
           return [currentPath]
         else return explicitPaths
-    sources :: Source IO SourceFile
-    sources = lift paths >>= mapM_ sourcesFromPath
-    formatSource source = do
-      formatter <- defaultFormatter
-      return $ applyFormatter formatter source
 
 sourcesFromPath :: FilePath -> Source IO SourceFile
 sourcesFromPath "-"  = yield StdinSource
@@ -65,11 +71,6 @@ applyFormatter (Formatter doFormat) (SourceFileWithContents file contents) =
     Left err       -> Left (FormatError file err)
     Right reformat -> Right (Formatted file contents reformat)
 
--- | Check that at least one value in the stream returns True.
---
--- Does not shortcut, entire stream is always consumed
-anyC' :: Monad m => (a -> Bool) -> Consumer a m Bool
-anyC' f = do
-  result <- anyC f -- Check for at least one value, may shortcut
-  sinkNull -- consume any remaining input skipped by a shortcut
-  return result
+bimapM :: Monad m => (a -> m c) -> (b -> m d) -> Either a b -> m (Either c d)
+bimapM f _ (Left a)  = Left <$> f a
+bimapM _ g (Right b) = Right <$> g b
diff --git a/app/Types.hs b/app/Types.hs
index 01b6869..eeece84 100644
--- a/app/Types.hs
+++ b/app/Types.hs
@@ -4,6 +4,7 @@ module Types
   , FormatError(..)
   , Formatted(..)
   , HaskellSource(..)
+  , RunResult(..)
   , SourceFile(..)
   , SourceFileWithContents(..)
   ) where
@@ -43,3 +44,17 @@ data Formatted =
   Formatted SourceFile
             HaskellSource
             Reformatted
+
+data RunResult
+  = OperationalFailure
+  | SourceParseFailure
+  | HadDifferences
+  | NoDifferences
+
+instance Monoid RunResult where
+  mempty = NoDifferences
+  x `mappend` NoDifferences = x
+  NoDifferences `mappend` x = x
+  OperationalFailure `mappend` _ = OperationalFailure
+  SourceParseFailure `mappend` _ = SourceParseFailure
+  HadDifferences `mappend` _ = HadDifferences