Convert Json module from String to ByteString

haskell · Jul 10, 2020 · bc9558e · bc9558e
1 parent 44cfe7d
commit bc9558e
Show file tree

Hide file tree

Showing 6 changed files with 63 additions and 57 deletions.
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
@@ -349,7 +349,7 @@ library
 
   if !impl(ghc >= 7.8)
     -- semigroups depends on tagged.
-    build-depends:  tagged >=0.8.6 && <0.9
+    build-depends:  tagged >=0.8.6 && <0.9, bytestring-builder >= 0.10.8 && <0.11
 
   exposed-modules:
     Distribution.Backpack
@@ -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,

diff --git a/Cabal/Distribution/Simple.hs b/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'
 

diff --git a/Cabal/Distribution/Simple/Build.hs b/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

diff --git a/Cabal/Distribution/Simple/ShowBuildInfo.hs b/Cabal/Distribution/Simple/ShowBuildInfo.hs
@@ -70,7 +70,7 @@ 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
@@ -88,8 +88,6 @@ 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)

diff --git a/Cabal/Distribution/Simple/Utils/Json.hs b/Cabal/Distribution/Simple/Utils/Json.hs
diff --git a/Cabal/Distribution/Utils/Json.hs b/Cabal/Distribution/Utils/Json.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE RankNTypes #-}
+{-# 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 qualified Data.ByteString.Lazy as LBS
+import Data.ByteString.Builder
+  ( Builder, stringUtf8, intDec, toLazyByteString )
+
+data Json = JsonArray [Json]
+          | JsonBool !Bool
+          | JsonNull
+          | JsonNumber !Int -- No support for Floats, Doubles just yet
+          | JsonObject [(String, Json)]
+          | JsonString !String
+
+-- | Convert a 'Json' into a 'ByteString'
+renderJson :: Json -> LBS.ByteString
+renderJson json = toLazyByteString (go json)
+  where
+    go (JsonArray objs)   =
+      surround "[" "]" $ mconcat $ intersperse "," $ 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 "," $ map render attrs
+      where
+        render (k,v) = (surround "\"" "\"" $ stringUtf8 (escape k)) <> ":" <> go v
+    go (JsonString s)     = surround "\"" "\"" $ stringUtf8 (escape s)
+
+surround :: Builder -> Builder -> Builder -> Builder
+surround begin end middle = mconcat [ begin , middle , end]
+
+escape :: String -> String
+escape ('\"':xs) = "\\\"" <> escape xs
+escape ('\\':xs) = "\\\\" <> escape xs
+escape ('\'':xs) = "\\\'" <> escape xs
+escape (x:xs)    = x : escape xs
+escape []        = mempty
+
+-- | A shorthand for building up 'JsonObject's
+-- > JsonObject [ "a" .= JsonNumber 42, "b" .= JsonBool True ]
+(.=) :: String -> Json -> (String, Json)
+k .= v = (k, v)