From c9cb617be6a490517fbf0ff0c1b9afe7bf3d54c2 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 8 Jul 2020 17:11:31 +0100 Subject: [PATCH] Convert Json module from String to ByteString --- Cabal/Cabal.cabal | 4 +- Cabal/Distribution/Simple.hs | 5 +- Cabal/Distribution/Simple/Build.hs | 7 +-- Cabal/Distribution/Simple/ShowBuildInfo.hs | 32 +++++++------ Cabal/Distribution/Simple/Utils/Json.hs | 46 ------------------ Cabal/Distribution/Utils/Json.hs | 54 ++++++++++++++++++++++ 6 files changed, 80 insertions(+), 68 deletions(-) delete mode 100644 Cabal/Distribution/Simple/Utils/Json.hs create mode 100644 Cabal/Distribution/Utils/Json.hs diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 72c09023ef0..7d6c440f017 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -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 index 5543765a10d..c3ee006c193 100644 --- 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 index c7e5ebfdb92..cec02c4cfbf 100644 --- 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 index 74f5de2d41b..08a0ec41331 100644 --- a/Cabal/Distribution/Simple/ShowBuildInfo.hs +++ b/Cabal/Distribution/Simple/ShowBuildInfo.hs @@ -54,6 +54,8 @@ -- Note: At the moment this is only supported when using the GHC compiler. -- +{-# LANGUAGE OverloadedStrings #-} + module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where import Distribution.Compat.Prelude @@ -70,11 +72,13 @@ 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 +import qualified Data.ByteString.Lazy.Char8 as B + -- | Construct a JSON document describing the build information for a -- package. mkBuildInfo @@ -88,22 +92,20 @@ 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-version" .= JsonString (B.pack $ display cabalVersion) , "compiler" .= mkCompilerInfo , "components" .= JsonArray (map mkComponentInfo componentsToBuild) ] mkCompilerInfo = JsonObject - [ "flavour" .= JsonString (prettyShow $ compilerFlavor $ compiler lbi) - , "compiler-id" .= JsonString (showCompilerId $ compiler lbi) + [ "flavour" .= JsonString (B.pack $ prettyShow $ compilerFlavor $ compiler lbi) + , "compiler-id" .= JsonString (B.pack $ showCompilerId $ compiler lbi) , "path" .= path ] where - path = maybe JsonNull (JsonString . programPath) + path = maybe JsonNull (JsonString . B.pack . programPath) $ (flavorToProgram . compilerFlavor $ compiler lbi) >>= flip lookupProgram (withPrograms lbi) @@ -115,13 +117,13 @@ mkBuildInfo pkg_descr lbi _flags targetsToBuild = info flavorToProgram _ = Nothing mkComponentInfo (name, clbi) = JsonObject - [ "type" .= JsonString compType - , "name" .= JsonString (prettyShow name) - , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) + [ "type" .= JsonString (B.pack compType) + , "name" .= JsonString (B.pack $ prettyShow name) + , "unit-id" .= JsonString (B.pack $ prettyShow $ componentUnitId clbi) , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi) - , "modules" .= JsonArray (map (JsonString . display) modules) - , "src-files" .= JsonArray (map JsonString sourceFiles) - , "src-dirs" .= JsonArray (map JsonString $ hsSourceDirs bi) + , "modules" .= JsonArray (map (JsonString . B.pack . display) modules) + , "src-files" .= JsonArray (map (JsonString . B.pack) sourceFiles) + , "src-dirs" .= JsonArray (map (JsonString . B.pack) $ hsSourceDirs bi) ] where bi = componentBuildInfo comp @@ -147,7 +149,7 @@ getCompilerArgs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo - -> [String] + -> [B.ByteString] getCompilerArgs bi lbi clbi = case compilerFlavor $ compiler lbi of GHC -> ghc @@ -156,6 +158,6 @@ getCompilerArgs bi lbi clbi = "build arguments for compiler "++show c where -- This is absolutely awful - ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts + ghc = map B.pack $ GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts where baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi) diff --git a/Cabal/Distribution/Simple/Utils/Json.hs b/Cabal/Distribution/Simple/Utils/Json.hs deleted file mode 100644 index f90f2f38aa2..00000000000 --- a/Cabal/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/Distribution/Utils/Json.hs b/Cabal/Distribution/Utils/Json.hs new file mode 100644 index 00000000000..c22b453e191 --- /dev/null +++ b/Cabal/Distribution/Utils/Json.hs @@ -0,0 +1,54 @@ +{-# 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 Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as C +import Data.ByteString.Builder + +data Json = JsonArray [Json] + | JsonBool !Bool + | JsonNull + | JsonNumber !Int + | JsonObject [(ByteString, Json)] + | JsonString !ByteString + +renderJson :: Json -> L.ByteString +renderJson json = toLazyByteString (go json) + where + go (JsonArray objs) = + surround "[" "]" $ mconcat $ intersperse (stringUtf8 ",") $ 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 (stringUtf8 ",") $ map render attrs + where + render (k,v) = (surround "\"" "\"" $ escape k) <> stringUtf8 ":" <> go v + go (JsonString s) = surround "\"" "\"" $ escape s + +surround :: ByteString -> ByteString -> Builder -> Builder +surround begin end middle = mconcat [ lazyByteString begin , middle , lazyByteString end] + +escape :: ByteString -> Builder +escape = escapeWorker + where + escapeWorker :: ByteString -> Builder + escapeWorker s = + case C.uncons s of + Just ('\"', xs) -> stringUtf8 "\\\"" <> escapeWorker xs + Just ('\\', xs) -> stringUtf8 "\\\\" <> escapeWorker xs + Just ('\'', xs) -> stringUtf8 "\\\'" <> escapeWorker xs + Just (x, xs) -> charUtf8 x <> escapeWorker xs + Nothing -> mempty + +(.=) :: ByteString -> Json -> (ByteString, Json) +k .= v = (k, v)