diff --git a/Data/Aeson/Encode/Pretty.hs b/Data/Aeson/Encode/Pretty.hs --- a/Data/Aeson/Encode/Pretty.hs +++ b/Data/Aeson/Encode/Pretty.hs @@ -1,65 +1,145 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} -- |Aeson-compatible pretty-printing of JSON 'Value's. -module Data.Aeson.Encode.Pretty (encodePretty, encodePretty') where +module Data.Aeson.Encode.Pretty ( + -- * Simple Pretty-Printing + encodePretty, + + -- * Pretty-Printing with Configuration Options + encodePretty', + Config (..), defConfig, + -- ** Sorting Keys in Objects + -- |With the Aeson library, the order of keys in objects is undefined due + -- objects being implemented as HashMaps. To allow user-specified key + -- orders in the pretty-printed JSON, 'encodePretty'' can be configured + -- with a comparison function. These comparison functions can be composed + -- using the 'Monoid' interface. Some other useful helper functions to keep + -- in mind are 'comparing' and 'on'. + -- + -- Consider the following deliberately convoluted example, demonstrating + -- the use of comparison functions: + -- + -- An object might pretty-print as follows + -- + -- > { + -- > "baz": ..., + -- > "bar": ..., + -- > "foo": ..., + -- > "quux": ..., + -- > } + -- + -- which is clearly a confusing order of keys. By using a comparison + -- function such as + -- + -- > comp :: Text -> Text -> Ordering + -- > comp = keyOrder ["foo","bar"] `mappend` comparing length + -- + -- we can achieve the desired neat result: + -- + -- > { + -- > "foo": ..., + -- > "bar": ..., + -- > "baz": ..., + -- > "quux": ..., + -- > } + -- + + mempty, + -- |Serves as an order-preserving (non-)sort function. Re-exported from + -- "Data.Monoid". + compare, + -- |Sort keys in their natural order, i.e. by comparing character codes. + -- Re-exported from the Prelude and "Data.Ord" + keyOrder +) where import Data.Aeson (Value(..), ToJSON(..)) import qualified Data.Aeson.Encode as Aeson import Data.ByteString.Lazy (ByteString) +import Data.Function (on) import qualified Data.HashMap.Strict as H (toList) -import Data.List (intersperse) +import Data.List (intersperse, sortBy, elemIndex) +import Data.Maybe (fromMaybe) import Data.Monoid (mappend, mconcat, mempty) +import Data.Ord import Data.Text (Text) import Data.Text.Lazy.Builder (Builder, toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) import qualified Data.Vector as V (toList) +data PState = PState { pstIndent :: Int + , pstLevel :: Int + , pstSort :: [(Text, Value)] -> [(Text, Value)] + } -type Indent = (Int, Int) -- (spaces per lvl, lvl) +data Config = Config + { confIndent :: Int + -- ^ Indentation spaces per level of nesting + , confCompare :: Text -> Text -> Ordering + -- ^ Function used to sort keys in objects + } +-- |Sort keys by their order of appearance in the argument list. +-- +-- Keys that are not present in the argument list are considered to be greater +-- than any key in the list and equal to all keys not in the list. I.e. keys +-- not in the argument list are moved to the end, while their order is +-- preserved. +keyOrder :: [Text] -> Text -> Text -> Ordering +keyOrder ks = comparing $ \k -> fromMaybe maxBound (elemIndex k ks) + + +-- |The default configuration: indent by four spaces per level of nesting, do +-- not sort objects by key. +-- +-- > defConfig = Config { confIndent = 4, confSort = mempty } +defConfig :: Config +defConfig = Config { confIndent = 4, confCompare = mempty } + -- |A drop-in replacement for aeson's 'Aeson.encode' function, producing -- JSON-ByteStrings for human readers. -- --- Indents by four spaces per nesting-level. +-- Follows the default configuration in 'defConfig'. encodePretty :: ToJSON a => a -> ByteString -encodePretty = encodePretty' 4 -- default indentation is four spaces +encodePretty = encodePretty' defConfig --- |A variant of 'encodePretty' that takes an additional parameter: the number --- of spaces to indent per nesting-level. -encodePretty' :: ToJSON a => Int -> a -> ByteString -encodePretty' spacesPerLvl = encodeUtf8 . toLazyText . fromValue ind . toJSON +-- |A variant of 'encodePretty' that takes an additional configuration +-- parameter. +encodePretty' :: ToJSON a => Config -> a -> ByteString +encodePretty' Config{..} = encodeUtf8 . toLazyText . fromValue st . toJSON where - ind = (spacesPerLvl, 0) + st = PState confIndent 0 condSort + condSort = sortBy (confCompare `on` fst) -fromValue :: Indent -> Value -> Builder -fromValue ind = go +fromValue :: PState -> Value -> Builder +fromValue st@PState{..} = go where - go (Array v) = fromCompound ind ("[","]") fromValue (V.toList v) - go (Object m) = fromCompound ind ("{","}") fromPair (H.toList m) + go (Array v) = fromCompound st ("[","]") fromValue (V.toList v) + go (Object m) = fromCompound st ("{","}") fromPair (pstSort (H.toList m)) go v = Aeson.fromValue v -fromCompound :: Indent +fromCompound :: PState -> (Builder, Builder) - -> (Indent -> a -> Builder) + -> (PState -> a -> Builder) -> [a] -> Builder -fromCompound ind (delimL,delimR) fromItem items = mconcat +fromCompound st@PState{..} (delimL,delimR) fromItem items = mconcat [ delimL , if null items then mempty - else "\n" <> items' <> "\n" <> fromIndent ind + else "\n" <> items' <> "\n" <> fromIndent st , delimR ] where items' = mconcat . intersperse ",\n" $ - map (\item -> fromIndent ind' <> fromItem ind' item) + map (\item -> fromIndent st' <> fromItem st' item) items - ind' = let (spacesPerLvl, lvl) = ind in (spacesPerLvl, lvl + 1) + st' = st { pstLevel = pstLevel + 1 } -fromPair :: Indent -> (Text, Value) -> Builder -fromPair ind (k,v) = Aeson.fromValue (toJSON k) <> ": " <> fromValue ind v +fromPair :: PState -> (Text, Value) -> Builder +fromPair st (k,v) = Aeson.fromValue (toJSON k) <> ": " <> fromValue st v -fromIndent :: Indent -> Builder -fromIndent (spacesPerLvl, lvl) = mconcat $ replicate (spacesPerLvl * lvl) " " +fromIndent :: PState -> Builder +fromIndent PState{..} = mconcat $ replicate (pstIndent * pstLevel) " " (<>) :: Builder -> Builder -> Builder (<>) = mappend diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, RecordWildCards, OverloadedStrings #-} -module Main (main) where - -import Prelude hiding (interact, concat, unlines, null) -import Data.Aeson (Value(..), json', encode) -import Data.Aeson.Encode.Pretty -import Data.Attoparsec.Lazy (Result(..), parse) -import Data.ByteString.Lazy.Char8 (ByteString, interact, unlines, null) -import Data.Version (showVersion) -import Paths_aeson_pretty (version) -import System.Console.CmdArgs - - -data Options = Opts { compact :: Bool - , indent :: Int - } - deriving (Data, Typeable) - -opts :: Options -opts = Opts - { compact = False &= help "Compact output." - , indent = 4 &= help "Number of spaces per nesting-level (default 4)." - } &= program prog - &= summary smry - &= details info - where - prog = "aeson-pretty" - smry = prog++" "++showVersion version++": Pretty JSON, the easy way." - -info :: [String] -info = - [ "Read JSON from stdin and pretty-print to stdout. The complementary " - , "compact-mode removes whitespace from the input." - , "" - , "(c) Falko Peters 2011" - , "" - , "License: BSD3, for details see the source-repository at" - , "http://www.github.com/informatikr/aeson-pretty." - , "" - ] - -main :: IO () -main = do - Opts{..} <- cmdArgs opts - let enc = if compact then encode else encodePretty' indent - interact $ unlines . map enc . values - -values :: ByteString -> [Value] -values s = case parse json' s of - Done rest v -> v : values rest - Fail rest _ _ - | null rest -> [] - | otherwise -> error "invalid json" diff --git a/aeson-pretty.cabal b/aeson-pretty.cabal --- a/aeson-pretty.cabal +++ b/aeson-pretty.cabal @@ -1,5 +1,5 @@ name: aeson-pretty -version: 0.6.3 +version: 0.7 license: BSD3 license-file: LICENSE category: Text, Web, JSON, Pretty Printer @@ -35,41 +35,37 @@ description: Only build/install the library, NOT the command-line tool. default: False +library + exposed-modules: + Data.Aeson.Encode.Pretty + + build-depends: + aeson >= 0.6, + base == 4.*, + bytestring >= 0.9, + vector >= 0.9, + text >= 0.11, + unordered-containers >= 0.1.3.0 + + ghc-options: -Wall + executable aeson-pretty + hs-source-dirs: cli-tool main-is: Main.hs if flag(lib-only) buildable: False else build-depends: - aeson == 0.6.*, - attoparsec == 0.10.*, + aeson >= 0.6, + aeson-pretty, + attoparsec >= 0.10, base == 4.*, - bytestring >= 0.9 && < 0.11, - cmdargs >= 0.7, - containers, - vector >= 0.9 && < 0.11, - text == 0.11.*, - unordered-containers >= 0.1.3.0 + bytestring >= 0.9, + cmdargs >= 0.7 ghc-options: -Wall ghc-prof-options: -auto-all - -library - exposed-modules: - Data.Aeson.Encode.Pretty - - build-depends: - aeson == 0.6.*, - attoparsec == 0.10.*, - base == 4.*, - bytestring >= 0.9 && < 0.11, - containers, - vector >= 0.9 && < 0.11, - text == 0.11.*, - unordered-containers >= 0.1.3.0 - - ghc-options: -Wall source-repository head type: git diff --git a/cli-tool/Main.hs b/cli-tool/Main.hs new file mode 100644 --- /dev/null +++ b/cli-tool/Main.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveDataTypeable, RecordWildCards, OverloadedStrings #-} +module Main (main) where + +import Prelude hiding (interact, concat, unlines, null) +import Data.Aeson (Value(..), json', encode) +import Data.Aeson.Encode.Pretty +import Data.Attoparsec.Lazy (Result(..), parse) +import Data.ByteString.Lazy.Char8 (ByteString, interact, unlines, null) +import Data.Version (showVersion) +import Paths_aeson_pretty (version) +import System.Console.CmdArgs + + +data Options = Opts { compact :: Bool + , indent :: Int + , sort :: Bool + } + deriving (Data, Typeable) + +opts :: Options +opts = Opts + { compact = False &= help "Compact output." + , indent = 4 &= help "Number of spaces per nesting-level (default 4)." + , sort = False &= help "Sort objects by key (default false)." + } &= program prog + &= summary smry + &= details info + where + prog = "aeson-pretty" + smry = prog++" "++showVersion version++": Pretty JSON, the easy way." + +info :: [String] +info = + [ "Read JSON from stdin and pretty-print to stdout. The complementary " + , "compact-mode removes whitespace from the input." + , "" + , "(c) Falko Peters 2011" + , "" + , "License: BSD3, for details see the source-repository at" + , "http://www.github.com/informatikr/aeson-pretty." + , "" + ] + +main :: IO () +main = do + Opts{..} <- cmdArgs opts + let conf = Config { confIndent = indent + , confCompare = if sort then compare else mempty + } + enc = if compact then encode else encodePretty' conf + interact $ unlines . map enc . values + +values :: ByteString -> [Value] +values s = case parse json' s of + Done rest v -> v : values rest + Fail rest _ _ + | null rest -> [] + | otherwise -> error "invalid json"