Merge pull request #7477 from fendor/json-bytestring

Json bytestring

Cabal-tests/Cabal-tests.cabal

@@ -40,6 +40,7 @@ test-suite unit-tests
     UnitTests.Distribution.Types.GenericPackageDescription
     UnitTests.Distribution.Utils.CharSet
     UnitTests.Distribution.Utils.Generic
+    UnitTests.Distribution.Utils.Json
     UnitTests.Distribution.Utils.NubList
     UnitTests.Distribution.Utils.ShortText
     UnitTests.Distribution.Utils.Structured

Cabal-tests/tests/UnitTests.hs

@@ -23,6 +23,7 @@ import qualified UnitTests.Distribution.Simple.Utils
 import qualified UnitTests.Distribution.System
 import qualified UnitTests.Distribution.Utils.CharSet
 import qualified UnitTests.Distribution.Utils.Generic
+import qualified UnitTests.Distribution.Utils.Json
 import qualified UnitTests.Distribution.Utils.NubList
 import qualified UnitTests.Distribution.Utils.ShortText
 import qualified UnitTests.Distribution.Utils.Structured
@@ -57,6 +58,8 @@ tests mtimeChangeCalibrated =
         UnitTests.Distribution.Simple.Utils.tests ghcPath
     , testGroup "Distribution.Utils.Generic"
         UnitTests.Distribution.Utils.Generic.tests
+    , testGroup "Distribution.Utils.Json" $
+        UnitTests.Distribution.Utils.Json.tests
     , testGroup "Distribution.Utils.NubList"
         UnitTests.Distribution.Utils.NubList.tests
     , testGroup "Distribution.Utils.ShortText"

Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs

+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+module UnitTests.Distribution.Utils.Json
+    ( tests
+    ) where
+
+import Distribution.Utils.Json
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+tests :: [TestTree]
+tests =
+    [ testCase "escapes strings correctly" $
+      renderJson (JsonString "foo\"bar") @?= "\"foo\\\"bar\""
+    , testCase "renders empty list" $
+      renderJson (JsonArray []) @?= "[]"
+    , testCase "renders singleton list" $
+      renderJson (JsonArray [JsonString "foo\"bar"]) @?= "[\"foo\\\"bar\"]"
+    , testCase "renders list" $
+      renderJson (JsonArray [JsonString "foo\"bar", JsonString "baz"]) @?= "[\"foo\\\"bar\",\"baz\"]"
+    , testCase "renders empty object" $
+      renderJson (JsonObject []) @?= "{}"
+    , testCase "renders singleton object" $
+      renderJson (JsonObject [("key", JsonString "foo\"bar")]) @?= "{\"key\":\"foo\\\"bar\"}"
+    , testCase "renders object" $
+      renderJson (JsonObject
+                    [ ("key", JsonString "foo\"bar")
+                    , ("key2", JsonString "baz")])
+          @?= "{\"key\":\"foo\\\"bar\",\"key2\":\"baz\"}"
+    , testCase "renders number" $
+      renderJson (JsonNumber 0) @?= "0"
+    , testCase "renders negative number" $
+      renderJson (JsonNumber (-1)) @?= "-1"
+    , testCase "renders big number" $
+      renderJson (JsonNumber 5000000) @?= "5000000"
+    , testCase "renders bool" $ do
+      renderJson (JsonBool True) @?= "true"
+      renderJson (JsonBool False) @?= "false"
+    , testCase "renders null" $ do
+      renderJson JsonNull @?= "null"
+    ]

Cabal/Cabal.cabal

@@ -75,7 +75,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
@@ -254,6 +254,7 @@ library
     Distribution.Types.GivenComponent
     Distribution.Types.PackageVersionConstraint
     Distribution.Utils.Generic
+    Distribution.Utils.Json
     Distribution.Utils.NubList
     Distribution.Utils.ShortText
     Distribution.Utils.Progress
@@ -337,7 +338,6 @@ library
     Distribution.Simple.GHC.EnvironmentParser
     Distribution.Simple.GHC.Internal
     Distribution.Simple.GHC.ImplInfo
-    Distribution.Simple.Utils.Json
     Distribution.ZinzaPrelude
     Paths_Cabal
 

Cabal/src/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
@@ -285,8 +286,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/src/Distribution/Simple/Build.hs

@@ -77,7 +77,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
@@ -87,6 +87,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 )
@@ -136,13 +137,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/src/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
@@ -89,8 +89,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)

Cabal/src/Distribution/Simple/Utils/Json.hs

--- | Utility json lib for Cabal
--- TODO: Remove it again.
-module Distribution.Simple.Utils.Json
-    ( Json(..)
-    , renderJson
-    ) where
-
-data Json = JsonArray [Json]
-          | JsonBool !Bool
-          | JsonNull
-          | JsonNumber !Int
-          | JsonObject [(String, Json)]
-          | JsonString !String
-
-renderJson :: Json -> ShowS
-renderJson (JsonArray objs)   =
-  surround "[" "]" $ intercalate "," $ map renderJson objs
-renderJson (JsonBool True)    = showString "true"
-renderJson (JsonBool False)   = showString "false"
-renderJson  JsonNull          = showString "null"
-renderJson (JsonNumber n)     = shows n
-renderJson (JsonObject attrs) =
-  surround "{" "}" $ intercalate "," $ map render attrs
-  where
-    render (k,v) = (surround "\"" "\"" $ showString' k) . showString ":" . renderJson v
-renderJson (JsonString s)     = surround "\"" "\"" $ showString' s
-
-surround :: String -> String -> ShowS -> ShowS
-surround begin end middle = showString begin . middle . showString end
-
-showString' :: String -> ShowS
-showString' xs = showStringWorker xs
-    where
-        showStringWorker :: String -> ShowS
-        showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as
-        showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as
-        showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as
-        showStringWorker (x:as) = showString [x] . showStringWorker as
-        showStringWorker [] = showString ""
-
-intercalate :: String -> [ShowS] -> ShowS
-intercalate sep = go
-  where
-    go []     = id
-    go [x]    = x
-    go (x:xs) = x . showString' sep . go xs

Cabal/src/Distribution/Utils/Json.hs

+{-# 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
+  deriving Show
+
+-- | 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 ('\b':xs) = "\\b"  <> escape xs
+escape ('\f':xs) = "\\f"  <> escape xs
+escape ('\n':xs) = "\\n"  <> escape xs
+escape ('\r':xs) = "\\r"  <> escape xs
+escape ('\t':xs) = "\\t"  <> escape xs
+escape (x:xs)    = x : escape xs
+escape []        = mempty
+
+-- | A shorthand for building up 'JsonObject's
+-- >>> JsonObject [ "a" .= JsonNumber 42, "b" .= JsonBool True ]
+-- JsonObject [("a",JsonNumber 42),("b",JsonBool True)]
+(.=) :: String -> Json -> (String, Json)
+k .= v = (k, v)