From eb41652cbd494adaafcd30c53f4159b6a3ce35d2 Mon Sep 17 00:00:00 2001
From: Rob Rix <rob.rix@me.com>
Date: Fri, 11 May 2018 16:37:04 -0400
Subject: [PATCH] Output to builders.

---
 src/Analysis/Abstract/Graph.hs |  3 +--
 src/Data/Output.hs             | 25 ++++++++-----------------
 src/Rendering/Imports.hs       |  3 +--
 src/Rendering/JSON.hs          |  3 +--
 src/Rendering/TOC.hs           |  3 +--
 src/Semantic/CLI.hs            |  7 ++++---
 src/Semantic/IO.hs             | 11 ++++++-----
 7 files changed, 22 insertions(+), 33 deletions(-)

diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs
index 1df3b3038..ec34c4958 100644
--- a/src/Analysis/Abstract/Graph.hs
+++ b/src/Analysis/Abstract/Graph.hs
@@ -24,7 +24,6 @@ import           Data.Abstract.Package (PackageInfo(..))
 import           Data.Aeson hiding (Result)
 import           Data.ByteString.Builder
 import qualified Data.ByteString.Char8 as BC
-import           Data.ByteString.Lazy (toStrict)
 import           Data.Graph
 import           Data.Output
 import qualified Data.Syntax as Syntax
@@ -144,7 +143,7 @@ appendGraph = modify' . (<>)
 
 
 instance Output (Graph Vertex) where
-  toOutput = toStrict . (<> "\n") . encode
+  toOutput = fromEncoding . toEncoding
 
 instance ToJSON Vertex where
   toJSON v = object [ "name" .= vertexToText v, "type" .= vertexToType v ]
diff --git a/src/Data/Output.hs b/src/Data/Output.hs
index c64fe9c03..d288aea59 100644
--- a/src/Data/Output.hs
+++ b/src/Data/Output.hs
@@ -2,27 +2,18 @@ module Data.Output
 ( Output(..)
 ) where
 
-import Data.Aeson (Value, encode)
-import Data.ByteString.Builder (Builder, toLazyByteString)
-import Data.ByteString.Lazy (toStrict)
-import Data.Text (Text, intercalate)
-import Data.Text.Encoding (encodeUtf8)
+import Data.Aeson (Value, fromEncoding, toEncoding)
+import Data.ByteString.Builder (Builder, byteString)
 import Prologue
 
 class Monoid o => Output o where
-  toOutput :: o -> ByteString
-
-instance Output ByteString where
-  toOutput s = s
-
-instance Output [Text] where
-  toOutput = encodeUtf8 . intercalate "\n"
-
-instance Output (Map Text Value) where
-  toOutput = toStrict . (<> "\n") . encode
+  toOutput :: o -> Builder
 
 instance Output [Value] where
-  toOutput = toStrict . (<> "\n") . encode
+  toOutput = fromEncoding . toEncoding
+
+instance Output ByteString where
+  toOutput = byteString
 
 instance Output Builder where
-  toOutput = toStrict . toLazyByteString
+  toOutput = id
diff --git a/src/Rendering/Imports.hs b/src/Rendering/Imports.hs
index 6b593e76f..7dfe66c0c 100644
--- a/src/Rendering/Imports.hs
+++ b/src/Rendering/Imports.hs
@@ -9,7 +9,6 @@ import Analysis.Declaration
 import Analysis.PackageDef
 import Data.Aeson
 import Data.Blob
-import Data.ByteString.Lazy (toStrict)
 import Data.Record
 import Data.Output
 import Data.Span
@@ -30,7 +29,7 @@ instance Monoid ImportSummary where
   mappend = (<>)
 
 instance Output ImportSummary where
-  toOutput = toStrict . (<> "\n") . encode
+  toOutput = fromEncoding . toEncoding
 
 instance ToJSON ImportSummary where
   toJSON (ImportSummary m) = object [ "modules" .= m ]
diff --git a/src/Rendering/JSON.hs b/src/Rendering/JSON.hs
index e22825be9..3fe443de3 100644
--- a/src/Rendering/JSON.hs
+++ b/src/Rendering/JSON.hs
@@ -14,7 +14,6 @@ import Data.Aeson (ToJSON, toJSON, object, (.=))
 import Data.Aeson as A
 import Data.JSON.Fields
 import Data.Blob
-import Data.ByteString.Lazy (toStrict)
 import qualified Data.Map.Monoidal as Monoidal
 import Data.Output
 import Data.Patch
@@ -28,7 +27,7 @@ toJSONOutput key = JSONOutput . Monoidal.singleton key
 
 
 instance Output JSONOutput where
-  toOutput = toStrict . encode . unJSONOutput
+  toOutput = fromEncoding . toEncoding
 
 
 -- | Render a diff to a value representing its JSON.
diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs
index 3fd0f6899..2a4596c9f 100644
--- a/src/Rendering/TOC.hs
+++ b/src/Rendering/TOC.hs
@@ -21,7 +21,6 @@ import Analysis.Declaration
 import Data.Aeson
 import Data.Align (bicrosswalk)
 import Data.Blob
-import Data.ByteString.Lazy (toStrict)
 import Data.Diff
 import Data.Language as Language
 import Data.List (sortOn)
@@ -45,7 +44,7 @@ instance Monoid Summaries where
   mappend = (<>)
 
 instance Output Summaries where
-  toOutput = toStrict . (<> "\n") . encode
+  toOutput = fromEncoding . toEncoding
 
 instance ToJSON Summaries where
   toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ]
diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs
index 52570e772..bfbb92f82 100644
--- a/src/Semantic/CLI.hs
+++ b/src/Semantic/CLI.hs
@@ -6,6 +6,7 @@ module Semantic.CLI
 , runParse
 ) where
 
+import           Data.ByteString.Builder
 import           Data.File
 import           Data.Language (Language)
 import           Data.List (intercalate)
@@ -30,13 +31,13 @@ import           Text.Read
 main :: IO ()
 main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
 
-runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both File] -> Task.TaskEff ByteString
+runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both File] -> Task.TaskEff Builder
 runDiff (SomeRenderer diffRenderer) = fmap toOutput . Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs
 
-runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
+runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff Builder
 runParse (SomeRenderer parseTreeRenderer) = fmap toOutput . Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
 
-runASTParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
+runASTParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff Builder
 runASTParse (SomeRenderer parseTreeRenderer) = fmap toOutput . Semantic.astParseBlobs parseTreeRenderer <=< Task.readBlobs
 
 runGraph :: Semantic.GraphType -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff (Graph Vertex)
diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs
index 3a0ac68df..6c21a0b04 100644
--- a/src/Semantic/IO.hs
+++ b/src/Semantic/IO.hs
@@ -31,6 +31,7 @@ import qualified Data.Blob as Blob
 import           Data.Bool
 import           Data.File
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Builder as B
 import qualified Data.ByteString.Lazy as BL
 import           Data.Language
 import           Data.Source
@@ -42,7 +43,7 @@ import           System.Directory.Tree (AnchoredDirTree(..))
 import           System.Exit
 import           System.FilePath
 import           System.FilePath.Glob
-import           System.IO (Handle)
+import           System.IO (Handle, IOMode(..), withBinaryFile)
 import           Text.Read
 
 -- | Read a utf8-encoded file to a 'Blob'.
@@ -196,8 +197,8 @@ readBlobPairs = send . ReadBlobPairs
 readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project
 readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
 
--- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
-writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs ()
+-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
+writeToOutput :: Member Files effs => Either Handle FilePath -> B.Builder -> Eff effs ()
 writeToOutput path = send . WriteToOutput path
 
 
@@ -207,7 +208,7 @@ data Files out where
   ReadBlobs     :: Either Handle [File] -> Files [Blob.Blob]
   ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair]
   ReadProject   :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project
-  WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files ()
+  WriteToOutput :: Either Handle FilePath -> B.Builder -> Files ()
 
 -- | Run a 'Files' effect in 'IO'.
 runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a
@@ -218,7 +219,7 @@ runFiles = interpret $ \ files -> case files of
   ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths)
   ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source)
   ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
-  WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)
+  WriteToOutput destination contents -> liftIO (either B.hPutBuilder (\ path -> withBinaryFile path WriteMode . flip B.hPutBuilder) destination contents)
 
 
 -- | Catch exceptions in 'IO' actions embedded in 'Eff', handling them with the passed function.