diff --git a/Cabal-tests/Cabal-tests.cabal b/Cabal-tests/Cabal-tests.cabal index a194259817f..efc28c56a8f 100644 --- a/Cabal-tests/Cabal-tests.cabal +++ b/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 diff --git a/Cabal-tests/tests/UnitTests.hs b/Cabal-tests/tests/UnitTests.hs index 3721838f0dd..611e3dd5bdb 100644 --- a/Cabal-tests/tests/UnitTests.hs +++ b/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" diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs new file mode 100644 index 00000000000..5609a72b555 --- /dev/null +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Json.hs @@ -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\"}" + , 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" + ] diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 1b328a47702..988dcf91bed 100644 --- a/Cabal/Cabal.cabal +++ b/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 diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 3b6672a3c8b..fc915322968 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/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' diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index c5963c733ab..bbfbcc7c62a 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/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 diff --git a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs b/Cabal/src/Distribution/Simple/ShowBuildInfo.hs index 631685b1d57..5dfe8e3a107 100644 --- a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs +++ b/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) diff --git a/Cabal/src/Distribution/Simple/Utils/Json.hs b/Cabal/src/Distribution/Simple/Utils/Json.hs deleted file mode 100644 index f90f2f38aa2..00000000000 --- a/Cabal/src/Distribution/Simple/Utils/Json.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | 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 diff --git a/Cabal/src/Distribution/Utils/Json.hs b/Cabal/src/Distribution/Utils/Json.hs new file mode 100644 index 00000000000..cef32f04d6d --- /dev/null +++ b/Cabal/src/Distribution/Utils/Json.hs @@ -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)