Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Json bytestring #7477

Merged
merged 3 commits into from
Aug 15, 2021
Merged

Json bytestring #7477

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
cdf1984
Convert Json module from String to ByteString
lukel97 Jul 8, 2020
2e6d0db
Write tests for Cabal's JSON lib
fendor Jul 8, 2021
3abcee5
Add standard conform JSON Escaping
fendor Jul 8, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions Cabal-tests/Cabal-tests.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
3 changes: 3 additions & 0 deletions Cabal-tests/tests/UnitTests.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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"
Expand Down
42 changes: 42 additions & 0 deletions Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,42 @@
{-# 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\"}"
Comment on lines +27 to +30
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@Mikolaj, @emilypi Do we have some form of formatting standards for new code?

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

There's been no concrete discussion of standards. Don't worry about it for now, and we'll come up with one

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Right. We only have https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#conventions, as mentioned in PR template. I guess, for now, use whatever conventions exist in the snippet you edit, unless they are utterly insane (in which case, create a reformatting commit first).

, 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"
]
4 changes: 2 additions & 2 deletions Cabal/Cabal.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

From #6948 (comment)

This is wrong as is, but I'll fix it before merge. One can have older bytestring on newer GHC, though that is contrived corner-case. But Cabal should be exemplary in own definition :)

Does that mean we don't need this dependency? Ill try to remove it and see whether CI is green.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ok, I guess CI tells us that it is not fine. I still don't know why it is wrong though. @phadej Would you mind elaborating?

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@phadej: ping?


exposed-modules:
Distribution.Backpack
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down
5 changes: 3 additions & 2 deletions Cabal/src/Distribution/Simple.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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'

Expand Down
7 changes: 4 additions & 3 deletions Cabal/src/Distribution/Simple/Build.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 )
Expand Down Expand Up @@ -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
Expand Down
4 changes: 1 addition & 3 deletions Cabal/src/Distribution/Simple/ShowBuildInfo.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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)
Expand Down
46 changes: 0 additions & 46 deletions Cabal/src/Distribution/Simple/Utils/Json.hs
View file
Open in desktop

This file was deleted.

58 changes: 58 additions & 0 deletions Cabal/src/Distribution/Utils/Json.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,58 @@
{-# 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)