Convert Json module from String to ByteString

Cabal/Cabal.cabal

@@ -527,6 +527,7 @@ library
     Distribution.Types.GivenComponent
     Distribution.Types.PackageVersionConstraint
     Distribution.Utils.Generic
+    Distribution.Utils.Json
     Distribution.Utils.NubList
     Distribution.Utils.ShortText
     Distribution.Utils.Progress
@@ -609,7 +610,6 @@ library
     Distribution.Simple.GHC.EnvironmentParser
     Distribution.Simple.GHC.Internal
     Distribution.Simple.GHC.ImplInfo
-    Distribution.Simple.Utils.Json
     Distribution.ZinzaPrelude
     Paths_Cabal
 
@@ -689,7 +689,7 @@ test-suite unit-tests
     Distribution.Described
     Distribution.Utils.CharSet
     Distribution.Utils.GrammarRegex
-    
+
   main-is: UnitTests.hs
   build-depends:
     array,

Cabal/Distribution/Simple.hs

@@ -104,6 +104,7 @@ import Distribution.Compat.Directory        (makeAbsolute)
 import Distribution.Compat.Environment      (getEnvironment)
 import Distribution.Compat.GetShortPathName (getShortPathName)
 
+import qualified Data.ByteString.Lazy as B
 import Data.List       (unionBy, (\\))
 
 import Distribution.PackageDescription.Parsec
@@ -286,8 +287,8 @@ showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do
   buildInfoString <- showBuildInfo pkg_descr lbi' flags
 
   case fileOutput of
-    Nothing -> putStr buildInfoString
-    Just fp -> writeFile fp buildInfoString
+    Nothing -> B.putStr buildInfoString
+    Just fp -> B.writeFile fp buildInfoString
 
   postBuild hooks args flags' pkg_descr lbi'
 

Cabal/Distribution/Simple/Build.hs

@@ -76,7 +76,7 @@ import Distribution.Simple.Configure
 import Distribution.Simple.Register
 import Distribution.Simple.Test.LibV09
 import Distribution.Simple.Utils
-import Distribution.Simple.Utils.Json
+import Distribution.Utils.Json
 
 import Distribution.System
 import Distribution.Pretty
@@ -86,6 +86,7 @@ import Distribution.Version (thisVersion)
 import Distribution.Compat.Graph (IsNode(..))
 
 import Control.Monad
+import Data.ByteString.Lazy (ByteString)
 import qualified Data.Set as Set
 import System.FilePath ( (</>), (<.>), takeDirectory )
 import System.Directory ( getCurrentDirectory )
@@ -135,13 +136,13 @@ build pkg_descr lbi flags suffixes = do
 showBuildInfo :: PackageDescription  -- ^ Mostly information from the .cabal file
   -> LocalBuildInfo      -- ^ Configuration information
   -> BuildFlags          -- ^ Flags that the user passed to build
-  -> IO String
+  -> IO ByteString
 showBuildInfo pkg_descr lbi flags = do
   let verbosity = fromFlag (buildVerbosity flags)
   targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)
   let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)
       doc = mkBuildInfo pkg_descr lbi flags targetsToBuild
-  return $ renderJson doc ""
+  return $ renderJson doc
 
 
 repl     :: PackageDescription  -- ^ Mostly information from the .cabal file

Cabal/Distribution/Simple/ShowBuildInfo.hs

@@ -54,6 +54,8 @@
 -- Note: At the moment this is only supported when using the GHC compiler.
 --
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where
 
 import Distribution.Compat.Prelude
@@ -70,11 +72,13 @@ import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Program
 import Distribution.Simple.Setup
 import Distribution.Simple.Utils (cabalVersion)
-import Distribution.Simple.Utils.Json
+import Distribution.Utils.Json
 import Distribution.Types.TargetInfo
 import Distribution.Text
 import Distribution.Pretty
 
+import qualified Data.ByteString.Lazy.Char8 as B
+
 -- | Construct a JSON document describing the build information for a
 -- package.
 mkBuildInfo
@@ -88,22 +92,20 @@ mkBuildInfo pkg_descr lbi _flags targetsToBuild = info
     targetToNameAndLBI target =
       (componentLocalName $ targetCLBI target, targetCLBI target)
     componentsToBuild = map targetToNameAndLBI targetsToBuild
-    (.=) :: String -> Json -> (String, Json)
-    k .= v = (k, v)
 
     info = JsonObject
-      [ "cabal-version" .= JsonString (display cabalVersion)
+      [ "cabal-version" .= JsonString (B.pack $ display cabalVersion)
       , "compiler"      .= mkCompilerInfo
       , "components"    .= JsonArray (map mkComponentInfo componentsToBuild)
       ]
 
     mkCompilerInfo = JsonObject
-      [ "flavour"     .= JsonString (prettyShow $ compilerFlavor $ compiler lbi)
-      , "compiler-id" .= JsonString (showCompilerId $ compiler lbi)
+      [ "flavour"     .= JsonString (B.pack $ prettyShow $ compilerFlavor $ compiler lbi)
+      , "compiler-id" .= JsonString (B.pack $ showCompilerId $ compiler lbi)
       , "path"        .= path
       ]
       where
-        path = maybe JsonNull (JsonString . programPath)
+        path = maybe JsonNull (JsonString . B.pack . programPath)
                $ (flavorToProgram . compilerFlavor $ compiler lbi)
                >>= flip lookupProgram (withPrograms lbi)
 
@@ -115,13 +117,13 @@ mkBuildInfo pkg_descr lbi _flags targetsToBuild = info
         flavorToProgram _     = Nothing
 
     mkComponentInfo (name, clbi) = JsonObject
-      [ "type"          .= JsonString compType
-      , "name"          .= JsonString (prettyShow name)
-      , "unit-id"       .= JsonString (prettyShow $ componentUnitId clbi)
+      [ "type"          .= JsonString (B.pack compType)
+      , "name"          .= JsonString (B.pack $ prettyShow name)
+      , "unit-id"       .= JsonString (B.pack $ prettyShow $ componentUnitId clbi)
       , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi)
-      , "modules"       .= JsonArray (map (JsonString . display) modules)
-      , "src-files"     .= JsonArray (map JsonString sourceFiles)
-      , "src-dirs"      .= JsonArray (map JsonString $ hsSourceDirs bi)
+      , "modules"       .= JsonArray (map (JsonString . B.pack . display) modules)
+      , "src-files"     .= JsonArray (map (JsonString . B.pack) sourceFiles)
+      , "src-dirs"      .= JsonArray (map (JsonString . B.pack) $ hsSourceDirs bi)
       ]
       where
         bi = componentBuildInfo comp
@@ -147,7 +149,7 @@ getCompilerArgs
   :: BuildInfo
   -> LocalBuildInfo
   -> ComponentLocalBuildInfo
-  -> [String]
+  -> [B.ByteString]
 getCompilerArgs bi lbi clbi =
   case compilerFlavor $ compiler lbi of
       GHC   -> ghc
@@ -156,6 +158,6 @@ getCompilerArgs bi lbi clbi =
                        "build arguments for compiler "++show c
   where
     -- This is absolutely awful
-    ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts
+    ghc = map B.pack $ GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts
       where
         baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi)

Cabal/Distribution/Utils/Json.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Extremely simple JSON helper. Don't do anything too fancy with this!
+
+module Distribution.Utils.Json
+    ( Json(..)
+    , (.=)
+    , renderJson
+    ) where
+
+import Distribution.Compat.Prelude
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as C
+import Data.ByteString.Builder
+
+data Json = JsonArray [Json]
+          | JsonBool !Bool
+          | JsonNull
+          | JsonNumber !Int
+          | JsonObject [(ByteString, Json)]
+          | JsonString !ByteString
+
+renderJson :: Json -> L.ByteString
+renderJson json = toLazyByteString (go json)
+  where
+    go (JsonArray objs)   =
+      surround "[" "]" $ mconcat $ intersperse (stringUtf8 ",") $ map go objs
+    go (JsonBool True)    = stringUtf8 "true"
+    go (JsonBool False)   = stringUtf8 "false"
+    go  JsonNull          = stringUtf8 "null"
+    go (JsonNumber n)     = intDec n
+    go (JsonObject attrs) =
+      surround "{" "}" $ mconcat $ intersperse (stringUtf8 ",") $ map render attrs
+      where
+        render (k,v) = (surround "\"" "\"" $ escape k) <> stringUtf8 ":" <> go v
+    go (JsonString s)     = surround "\"" "\"" $ escape s
+
+surround :: ByteString -> ByteString -> Builder -> Builder
+surround begin end middle = mconcat [ lazyByteString begin , middle , lazyByteString end]
+
+escape :: ByteString -> Builder
+escape = escapeWorker
+  where
+    escapeWorker :: ByteString -> Builder
+    escapeWorker s =
+      case C.uncons s of
+        Just ('\"', xs) -> stringUtf8 "\\\"" <> escapeWorker xs
+        Just ('\\', xs) -> stringUtf8 "\\\\" <> escapeWorker xs
+        Just ('\'', xs) -> stringUtf8 "\\\'" <> escapeWorker xs
+        Just (x, xs)    -> charUtf8 x <> escapeWorker xs
+        Nothing         -> mempty
+
+(.=) :: ByteString -> Json -> (ByteString, Json)
+k .= v = (k, v)