Skip to content

Commit fd185f3

Browse files
emilypiemilypi
authored
Merge pull request #7477 from fendor/json-bytestring
Json bytestring
2 parents 0b06a13 + 3abcee5 commit fd185f3

File tree

9 files changed

+114
-56
lines changed

9 files changed

+114
-56
lines changed

‎Cabal-tests/Cabal-tests.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,7 @@ test-suite unit-tests
4040
UnitTests.Distribution.Types.GenericPackageDescription
4141
UnitTests.Distribution.Utils.CharSet
4242
UnitTests.Distribution.Utils.Generic
43+
UnitTests.Distribution.Utils.Json
4344
UnitTests.Distribution.Utils.NubList
4445
UnitTests.Distribution.Utils.ShortText
4546
UnitTests.Distribution.Utils.Structured

‎Cabal-tests/tests/UnitTests.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ import qualified UnitTests.Distribution.Simple.Utils
2323
import qualified UnitTests.Distribution.System
2424
import qualified UnitTests.Distribution.Utils.CharSet
2525
import qualified UnitTests.Distribution.Utils.Generic
26+
import qualified UnitTests.Distribution.Utils.Json
2627
import qualified UnitTests.Distribution.Utils.NubList
2728
import qualified UnitTests.Distribution.Utils.ShortText
2829
import qualified UnitTests.Distribution.Utils.Structured
@@ -57,6 +58,8 @@ tests mtimeChangeCalibrated =
5758
UnitTests.Distribution.Simple.Utils.tests ghcPath
5859
, testGroup "Distribution.Utils.Generic"
5960
UnitTests.Distribution.Utils.Generic.tests
61+
, testGroup "Distribution.Utils.Json" $
62+
UnitTests.Distribution.Utils.Json.tests
6063
, testGroup "Distribution.Utils.NubList"
6164
UnitTests.Distribution.Utils.NubList.tests
6265
, testGroup "Distribution.Utils.ShortText"

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

Lines changed: 42 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
module UnitTests.Distribution.Utils.Json
4+
( tests
5+
) where
6+
7+
import Distribution.Utils.Json
8+
9+
import Test.Tasty
10+
import Test.Tasty.HUnit
11+
12+
tests :: [TestTree]
13+
tests =
14+
[ testCase "escapes strings correctly" $
15+
renderJson (JsonString "foo\"bar") @?= "\"foo\\\"bar\""
16+
, testCase "renders empty list" $
17+
renderJson (JsonArray []) @?= "[]"
18+
, testCase "renders singleton list" $
19+
renderJson (JsonArray [JsonString "foo\"bar"]) @?= "[\"foo\\\"bar\"]"
20+
, testCase "renders list" $
21+
renderJson (JsonArray [JsonString "foo\"bar", JsonString "baz"]) @?= "[\"foo\\\"bar\",\"baz\"]"
22+
, testCase "renders empty object" $
23+
renderJson (JsonObject []) @?= "{}"
24+
, testCase "renders singleton object" $
25+
renderJson (JsonObject [("key", JsonString "foo\"bar")]) @?= "{\"key\":\"foo\\\"bar\"}"
26+
, testCase "renders object" $
27+
renderJson (JsonObject
28+
[ ("key", JsonString "foo\"bar")
29+
, ("key2", JsonString "baz")])
30+
@?= "{\"key\":\"foo\\\"bar\",\"key2\":\"baz\"}"
31+
, testCase "renders number" $
32+
renderJson (JsonNumber 0) @?= "0"
33+
, testCase "renders negative number" $
34+
renderJson (JsonNumber (-1)) @?= "-1"
35+
, testCase "renders big number" $
36+
renderJson (JsonNumber 5000000) @?= "5000000"
37+
, testCase "renders bool" $ do
38+
renderJson (JsonBool True) @?= "true"
39+
renderJson (JsonBool False) @?= "false"
40+
, testCase "renders null" $ do
41+
renderJson JsonNull @?= "null"
42+
]

‎Cabal/Cabal.cabal

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -75,7 +75,7 @@ library
7575

7676
if !impl(ghc >= 7.8)
7777
-- semigroups depends on tagged.
78-
build-depends: tagged >=0.8.6 && <0.9
78+
build-depends: tagged >=0.8.6 && <0.9, bytestring-builder >= 0.10.8 && <0.11
7979

8080
exposed-modules:
8181
Distribution.Backpack
@@ -254,6 +254,7 @@ library
254254
Distribution.Types.GivenComponent
255255
Distribution.Types.PackageVersionConstraint
256256
Distribution.Utils.Generic
257+
Distribution.Utils.Json
257258
Distribution.Utils.NubList
258259
Distribution.Utils.ShortText
259260
Distribution.Utils.Progress
@@ -337,7 +338,6 @@ library
337338
Distribution.Simple.GHC.EnvironmentParser
338339
Distribution.Simple.GHC.Internal
339340
Distribution.Simple.GHC.ImplInfo
340-
Distribution.Simple.Utils.Json
341341
Distribution.ZinzaPrelude
342342
Paths_Cabal
343343

‎Cabal/src/Distribution/Simple.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -104,6 +104,7 @@ import Distribution.Compat.Directory (makeAbsolute)
104104
import Distribution.Compat.Environment (getEnvironment)
105105
import Distribution.Compat.GetShortPathName (getShortPathName)
106106

107+
import qualified Data.ByteString.Lazy as B
107108
import Data.List (unionBy, (\\))
108109

109110
import Distribution.PackageDescription.Parsec
@@ -285,8 +286,8 @@ showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do
285286
buildInfoString <- showBuildInfo pkg_descr lbi' flags
286287

287288
case fileOutput of
288-
Nothing -> putStr buildInfoString
289-
Just fp -> writeFile fp buildInfoString
289+
Nothing -> B.putStr buildInfoString
290+
Just fp -> B.writeFile fp buildInfoString
290291

291292
postBuild hooks args flags' pkg_descr lbi'
292293

‎Cabal/src/Distribution/Simple/Build.hs

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -77,7 +77,7 @@ import Distribution.Simple.Configure
7777
import Distribution.Simple.Register
7878
import Distribution.Simple.Test.LibV09
7979
import Distribution.Simple.Utils
80-
import Distribution.Simple.Utils.Json
80+
import Distribution.Utils.Json
8181

8282
import Distribution.System
8383
import Distribution.Pretty
@@ -87,6 +87,7 @@ import Distribution.Version (thisVersion)
8787
import Distribution.Compat.Graph (IsNode(..))
8888

8989
import Control.Monad
90+
import Data.ByteString.Lazy (ByteString)
9091
import qualified Data.Set as Set
9192
import System.FilePath ( (</>), (<.>), takeDirectory )
9293
import System.Directory ( getCurrentDirectory )
@@ -136,13 +137,13 @@ build pkg_descr lbi flags suffixes = do
136137
showBuildInfo :: PackageDescription -- ^ Mostly information from the .cabal file
137138
-> LocalBuildInfo -- ^ Configuration information
138139
-> BuildFlags -- ^ Flags that the user passed to build
139-
-> IO String
140+
-> IO ByteString
140141
showBuildInfo pkg_descr lbi flags = do
141142
let verbosity = fromFlag (buildVerbosity flags)
142143
targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)
143144
let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)
144145
doc = mkBuildInfo pkg_descr lbi flags targetsToBuild
145-
return $ renderJson doc ""
146+
return $ renderJson doc
146147

147148

148149
repl :: PackageDescription -- ^ Mostly information from the .cabal file

‎Cabal/src/Distribution/Simple/ShowBuildInfo.hs

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -70,7 +70,7 @@ import Distribution.Simple.LocalBuildInfo
7070
import Distribution.Simple.Program
7171
import Distribution.Simple.Setup
7272
import Distribution.Simple.Utils (cabalVersion)
73-
import Distribution.Simple.Utils.Json
73+
import Distribution.Utils.Json
7474
import Distribution.Types.TargetInfo
7575
import Distribution.Text
7676
import Distribution.Pretty
@@ -89,8 +89,6 @@ mkBuildInfo pkg_descr lbi _flags targetsToBuild = info
8989
targetToNameAndLBI target =
9090
(componentLocalName $ targetCLBI target, targetCLBI target)
9191
componentsToBuild = map targetToNameAndLBI targetsToBuild
92-
(.=) :: String -> Json -> (String, Json)
93-
k .= v = (k, v)
9492

9593
info = JsonObject
9694
[ "cabal-version" .= JsonString (display cabalVersion)

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

Lines changed: 0 additions & 46 deletions
This file was deleted.

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

Lines changed: 58 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,58 @@
1+
{-# LANGUAGE RankNTypes #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
-- | Extremely simple JSON helper. Don't do anything too fancy with this!
4+
5+
module Distribution.Utils.Json
6+
( Json(..)
7+
, (.=)
8+
, renderJson
9+
) where
10+
11+
import Distribution.Compat.Prelude
12+
import qualified Data.ByteString.Lazy as LBS
13+
import Data.ByteString.Builder
14+
( Builder, stringUtf8, intDec, toLazyByteString )
15+
16+
data Json = JsonArray [Json]
17+
| JsonBool !Bool
18+
| JsonNull
19+
| JsonNumber !Int -- No support for Floats, Doubles just yet
20+
| JsonObject [(String, Json)]
21+
| JsonString !String
22+
deriving Show
23+
24+
-- | Convert a 'Json' into a 'ByteString'
25+
renderJson :: Json -> LBS.ByteString
26+
renderJson json = toLazyByteString (go json)
27+
where
28+
go (JsonArray objs) =
29+
surround "[" "]" $ mconcat $ intersperse "," $ map go objs
30+
go (JsonBool True) = stringUtf8 "true"
31+
go (JsonBool False) = stringUtf8 "false"
32+
go JsonNull = stringUtf8 "null"
33+
go (JsonNumber n) = intDec n
34+
go (JsonObject attrs) =
35+
surround "{" "}" $ mconcat $ intersperse "," $ map render attrs
36+
where
37+
render (k,v) = (surround "\"" "\"" $ stringUtf8 (escape k)) <> ":" <> go v
38+
go (JsonString s) = surround "\"" "\"" $ stringUtf8 (escape s)
39+
40+
surround :: Builder -> Builder -> Builder -> Builder
41+
surround begin end middle = mconcat [ begin , middle , end]
42+
43+
escape :: String -> String
44+
escape ('\"':xs) = "\\\"" <> escape xs
45+
escape ('\\':xs) = "\\\\" <> escape xs
46+
escape ('\b':xs) = "\\b" <> escape xs
47+
escape ('\f':xs) = "\\f" <> escape xs
48+
escape ('\n':xs) = "\\n" <> escape xs
49+
escape ('\r':xs) = "\\r" <> escape xs
50+
escape ('\t':xs) = "\\t" <> escape xs
51+
escape (x:xs) = x : escape xs
52+
escape [] = mempty
53+
54+
-- | A shorthand for building up 'JsonObject's
55+
-- >>> JsonObject [ "a" .= JsonNumber 42, "b" .= JsonBool True ]
56+
-- JsonObject [("a",JsonNumber 42),("b",JsonBool True)]
57+
(.=) :: String -> Json -> (String, Json)
58+
k .= v = (k, v)

0 commit comments

Comments
 (0)