diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,32 @@ +Opinionated Haskell Interoperability + +Copyright © 2018-2019 Operational Dynamics Consulting, Pty Ltd and Others +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 3. Neither the name of the project nor the names of its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/core-data.cabal b/core-data.cabal new file mode 100644 --- /dev/null +++ b/core-data.cabal @@ -0,0 +1,51 @@ +cabal-version: 1.12 +name: core-data +version: 0.2.0.0 +license: BSD3 +license-file: LICENCE +copyright: © 2018-2019 Operational Dynamics Consulting Pty Ltd, and Others +maintainer: Andrew Cowie +author: Andrew Cowie +stability: experimental +tested-with: ghc ==8.6.5 +homepage: https://github.com/oprdyn/unbeliever#readme +bug-reports: https://github.com/oprdyn/unbeliever/issues +synopsis: Convenience wrappers around common data structures and encodings +description: + Wrappers around common data structures and encodings. + . + This is part of a library intended to ease interoperability and assist in + building command-line programs, both tools and longer-running daemons. + A list of features and some background to the library's design is contained + in the + + on GitHub. +category: System +build-type: Simple + +source-repository head + type: git + location: https://github.com/oprdyn/unbeliever + +library + exposed-modules: + Core.Data + Core.Data.Structures + Core.Encoding + Core.Encoding.Json + hs-source-dirs: lib + default-language: Haskell2010 + ghc-options: -Wall -Wwarn -fwarn-tabs + build-depends: + aeson >=1.4.2.0 && <1.5, + base >=4.11 && <5, + bytestring >=0.10.8.2 && <0.11, + containers >=0.6.0.1 && <0.7, + core-text >=0.2.0.0 && <0.3, + hashable >=1.2.7.0 && <1.3, + prettyprinter >=1.2.1 && <1.3, + prettyprinter-ansi-terminal >=1.1.1.2 && <1.2, + scientific >=0.3.6.2 && <0.4, + text >=1.2.3.1 && <1.3, + unordered-containers >=0.2.10.0 && <0.3, + vector >=0.12.0.3 && <0.13 diff --git a/lib/Core/Data.hs b/lib/Core/Data.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Data.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| +Wrappers and adaptors for various data structures common in the Haskell +ecosystem. + +This is intended to be used directly: + +@ +import "Core.Data" +@ + +as this module re-exports all of its various components. +-} +module Core.Data + ( + {-* Wrappers -} +{-| +Exposes 'Map', a wrapper around a dictionary type, and 'Set', for +collections of elements. +-} + module Core.Data.Structures + ) where + +import Core.Data.Structures + diff --git a/lib/Core/Data/Structures.hs b/lib/Core/Data/Structures.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Data/Structures.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Convenience wrappers around dictionary and collection types and tools +facilitating conversion between them and various map and set types in +common use in the Haskell ecosystem. +-} +module Core.Data.Structures +( + {-* Map type -} + Map + , emptyMap + , singletonMap + , insertKeyValue + , containsKey + , lookupKeyValue + + {-* Conversions -} + , Dictionary(K, V, fromMap, intoMap) + + {-* Set type -} + , Set + , emptySet + , singletonSet + , insertElement + , containsElement + + {-* Conversions -} + , Collection(E, fromSet, intoSet) + + {-* Internals -} + , Key + , unMap + , unSet +) +where + +import Data.Foldable (Foldable(..)) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.Map.Strict as OrdMap +import qualified Data.Set as OrdSet +import qualified Data.Text as T (Text) +import qualified Data.Text.Lazy as U (Text) +import qualified GHC.Exts as Exts (IsList(..)) + +import Core.Text.Rope (Rope) +import Core.Text.Bytes (Bytes) + +-- Naming convention used throughout this file is (Thing u) where u is the +-- underlying structure [from unordered-containers] wrapped in the Thing +-- newtype. Leaves p for our Map and s for our Set in tests. + +{-| +A mapping from keys to values. + +The keys in a map needs to be an instance of the 'Key' typeclass. +Instances are already provided for many common element types. + +'Map' implements 'Foldable', 'Monoid', etc so many common operations such +as 'foldr' to reduce the structure with a right fold, 'length' to get the +number of key/value pairs in the dictionary, 'null' to test whether the +map is empty, and ('<>') to join two maps together are available. + +To convert to other dictionary types see 'fromMap' below. + +(this is a thin wrapper around __unordered-containers__'s +'Data.HashMap.Strict.HashMap', but if you use the conversion functions to +extract the key/value pairs in a list the list will be ordered according to +the keys' 'Ord' instance) +-} +newtype Map κ ν = Map (HashMap.HashMap κ ν) + deriving (Show, Eq) + +unMap :: Map κ ν -> HashMap.HashMap κ ν +unMap (Map u) = u +{-# INLINE unMap #-} + +{-| +Types that can be used as keys in dictionaries or elements in collections. + +To be an instance of 'Key' a type must implement both 'Hashable' and 'Ord'. +This requirement means we can subsequently offer easy conversion +between different the dictionary and collection types you might encounter +when interacting with other libraries. + +Instances for this library's 'Rope' and 'Bytes' are provided here, along +with many other common types. +-} +class (Hashable κ, Ord κ) => Key κ + +instance Key String +instance Key Rope +instance Key Bytes +instance Key T.Text +instance Key U.Text +instance Key Char +instance Key Int + +instance Foldable (Map κ) where + foldr f start (Map u) = HashMap.foldr f start u + null (Map u) = HashMap.null u + length (Map u) = HashMap.size u + +{-| +A dictionary with no key/value mappings. +-} +emptyMap :: Map κ ν +emptyMap = Map (HashMap.empty) + +{-| +Construct a dictionary with only a single key/value pair. +-} +singletonMap :: Key κ => κ -> ν -> Map κ ν +singletonMap k v = Map (HashMap.singleton k v) + +{-| +Insert a key/value pair into the dictionary. If the key is already present +in the dictionary, the old value will be discarded and replaced with the +value supplied here. +-} +insertKeyValue :: Key κ => κ -> ν -> Map κ ν -> Map κ ν +insertKeyValue k v (Map u) = Map (HashMap.insert k v u) + +{-| +If the dictionary contains the specified key, return the value associated +with that key. +-} +lookupKeyValue :: Key κ => κ -> Map κ ν -> Maybe ν +lookupKeyValue k (Map u) = HashMap.lookup k u + +{-| +Does the dictionary contain the specified key? +-} +containsKey :: Key κ => κ -> Map κ ν -> Bool +containsKey k (Map u) = HashMap.member k u + +{-| +-} +instance Key κ => Semigroup (Map κ ν) where + (<>) (Map u1) (Map u2) = Map (HashMap.union u1 u2) + +instance Key κ => Monoid (Map κ ν) where + mempty = emptyMap + mappend = (<>) + +instance Key κ => Exts.IsList (Map κ ν) where + type Item (Map κ ν) = (κ, ν) + fromList pairs = Map (HashMap.fromList pairs) + toList (Map u) = HashMap.toList u + +{-| +Types that represent key/value pairs that can be converted to 'Map's. +Haskell's ecosystem has several such. This typeclass provides an adaptor to +get between them. It also allows you to serialize out to an association +list. + +For example, to convert a 'Map' to an \"association list\" of key/value +pairs, use 'fromMap': + +@ + answers :: 'Map' 'Rope' 'Int' + answers = 'singletonMap' \"Life, The Universe, and Everything\" 42 + + list :: [('Rope','Int')] + list = 'fromMap' answers +@ + +Instances are provided for __containers__'s 'Data.Map.Strict.Map' and +__unordered-containers__'s 'Data.HashMap.Strict.HashMap' in addition to the +instance for @[(κ,ν)]@ lists shown above. +-} +-- +-- Getting an instance for [(κ,ν)] was very difficult. The approach +-- implemented below was suggested by Xia Li-yao, @Lysxia was to use +-- type families. +-- +-- > "Maybe you can change your type class to be indexed by the fully +-- > applied dictionary type, instead of a type constructor * -> * -> *" +-- +-- https://stackoverflow.com/questions/53554687/list-instances-for-higher-kinded-types/53556313 +-- +-- Many thanks for an elegant solution to the problem. +-- +class Dictionary α where + type K α :: * + type V α :: * + fromMap :: Map (K α) (V α) -> α + intoMap :: α -> Map (K α) (V α) + +instance Key κ => Dictionary (Map κ ν) where + type K (Map κ ν) = κ + type V (Map κ ν) = ν + fromMap = id + intoMap = id + +{-| from "Data.HashMap.Strict" (and .Lazy) -} +instance Key κ => Dictionary (HashMap.HashMap κ ν) where + type K (HashMap.HashMap κ ν) = κ + type V (HashMap.HashMap κ ν) = ν + fromMap (Map u) = u + intoMap u = Map u + +{-| from "Data.Map.Strict" (and .Lazy) -} +instance Key κ => Dictionary (OrdMap.Map κ ν) where + type K (OrdMap.Map κ ν) = κ + type V (OrdMap.Map κ ν) = ν + fromMap (Map u) = HashMap.foldrWithKey OrdMap.insert OrdMap.empty u + intoMap o = Map (OrdMap.foldrWithKey HashMap.insert HashMap.empty o) + +instance Key κ => Dictionary [(κ,ν)] where + type K [(κ,ν)] = κ + type V [(κ,ν)] = ν + fromMap (Map u) = OrdMap.toList (HashMap.foldrWithKey OrdMap.insert OrdMap.empty u) + intoMap kvs = Map (HashMap.fromList kvs) + +{-| +A set of unique elements. + +The element type needs to be an instance of the same 'Key' typeclass that +is used for keys in the 'Map' type above. Instances are already provided +for many common element types. + +'Set' implements 'Foldable', 'Monoid', etc so many common operations such +as 'foldr' to walk the elements and reduce them, 'length' to return the +size of the collection, 'null' to test whether is empty, and ('<>') to take +the union of two sets are available. + +To convert to other collection types see 'fromSet' below. + +(this is a thin wrapper around __unordered-containers__'s +'Data.HashSet.HashSet', but if you use the conversion functions to extract +a list the list will be ordered according to the elements' 'Ord' instance) +-} +newtype Set ε = Set (HashSet.HashSet ε) + deriving (Show, Eq) + +unSet :: Set ε -> HashSet.HashSet ε +unSet (Set u) = u +{-# INLINE unSet #-} + +instance Foldable Set where + foldr f start (Set u) = HashSet.foldr f start u + null (Set u) = HashSet.null u + length (Set u) = HashSet.size u + +instance Key ε => Semigroup (Set ε) where + (<>) (Set u1) (Set u2) = Set (HashSet.union u1 u2) + +instance Key ε => Monoid (Set ε) where + mempty = emptySet + mappend = (<>) + +{-| +An empty collection. This is used for example as an inital value when +building up a 'Set' using a fold. +-} +emptySet :: Key ε => Set ε +emptySet = Set (HashSet.empty) + +{-| +Construct a collection comprising only the supplied element. +-} +singletonSet :: Key ε => ε -> Set ε +singletonSet e = Set (HashSet.singleton e) + +{-| +Insert a new element into the collection. Since the 'Set' type does not +allow duplicates, inserting an element already in the collection has no +effect. +-} +insertElement :: Key ε => ε -> Set ε -> Set ε +insertElement e (Set u) = Set (HashSet.insert e u) + +{-| +Does the collection contain the specified element? +-} +containsElement :: Key ε => ε -> Set ε -> Bool +containsElement e (Set u) = HashSet.member e u + +{-| +Types that represent collections of elements that can be converted to +'Set's. Haskell's ecosystem has several such. This typeclass provides an +adaptor to convert between them. + +This typeclass also provides a mechanism to serialize a 'Set' out to a +Haskell list. The list will be ordered according to the 'Ord' instance of +the element type. + +Instances are provided for __containers__'s 'Data.Set.Set' and +__unordered-containers__'s 'Data.HashSet.HashSet' in addition to the +instance for @[ε]@ lists described above. +-} +class Collection α where + type E α :: * + fromSet :: Set (E α) -> α + intoSet :: α -> Set (E α) + +instance Key ε => Collection (Set ε) where + type E (Set ε) = ε + fromSet = id + intoSet = id + +{-| from "Data.HashSet" -} +instance Key ε => Collection (HashSet.HashSet ε) where + type E (HashSet.HashSet ε) = ε + fromSet (Set u) = u + intoSet u = Set u + +{-| from "Data.Set" -} +instance Key ε => Collection (OrdSet.Set ε) where + type E (OrdSet.Set ε) = ε + fromSet (Set u) = HashSet.foldr OrdSet.insert OrdSet.empty u + intoSet u = Set (OrdSet.foldr HashSet.insert HashSet.empty u) + +instance Key ε => Collection [ε] where + type E [ε] = ε + fromSet (Set u) = OrdSet.toList (HashSet.foldr OrdSet.insert OrdSet.empty u) + intoSet es = Set (HashSet.fromList es) diff --git a/lib/Core/Encoding.hs b/lib/Core/Encoding.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Encoding.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| +Various formats used for serialization, data transfer, and configuration. + +This can be used by simply importing the top level module: + +@ +import "Core.Encoding" +@ + +although the individual formats are quite usable indepedently. + +Each of these encodings are backed by a popular and well tuned library in +wide use across the Haskell community; these modules are here as wrappers +providing for ease of use and interoperability across the various tools in +this package. + +-} +module Core.Encoding + ( + module Core.Encoding.Json + ) where + +import Core.Encoding.Json + diff --git a/lib/Core/Encoding/Json.hs b/lib/Core/Encoding/Json.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Encoding/Json.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Encoding and decoding UTF-8 JSON content. + +This module is a thin wrapper around the most excellent __aeson__ library, +which has rich and powerful facilities for encoding Haskell types into +JSON. + +Quite often, however, you find yourself having to create a Haskell type +/just/ to read some JSON coming from an external web service or API. This +can be challenging when the source of the JSON is complex or varying its +schema over time. For ease of exploration this module simply defines an +easy to use intermediate type representing JSON as a format. + +Often you'll be working with literals directly in your code. While you can +write: + +@ + j = 'JsonObject' ('intoMap' [('JsonKey' "answer", 'JsonNumber' 42)]) +@ + +and it would be correct, enabling: + +@ +\{\-\# LANGUAGE OverloadedStrings \#\-\} +\{\-\# LANGUAGE OverloadedLists \#\-\} +@ + +allows you to write: + +@ + j = 'JsonObject' [("answer", 42)] +@ + +which you is somewhat less cumbersome in declaration-heavy code. You're +certainly welcome to use the constructors if you find it makes for more +readable code or if you need the type annotations. +-} +-- +-- As currently implemented this module, in conjunction with +-- Core.Text, is the opposite of efficient. The idea right now is to +-- experiment with the surface API. If it stabilizes, then the fact +-- that our string objects are already in UTF-8 will make for a very +-- efficient emitter. +-- +module Core.Encoding.Json + ( {-* Encoding and Decoding -} + encodeToUTF8 + , decodeFromUTF8 + , JsonValue(..) + , JsonKey(..) + {-* Syntax highlighting -} +{-| +Support for pretty-printing JSON values with syntax highlighting using the +__prettyprinter__ library. To output a JSON structure to terminal +colourized with ANSI escape codes you can use the 'Render' instance: + +@ + debug "j" (render j) +@ + +will get you: + +@ +23:46:04Z (00000.007) j = +{ + "answer": 42.0 +} +@ + +-} + , JsonToken(..) + , colourizeJson + , prettyKey + , prettyValue + ) where + +import qualified Data.Aeson as Aeson +import Data.Coerce +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Hashable (Hashable) +import Data.Text.Prettyprint.Doc + ( Doc, Pretty(..), viaShow, dquote, comma, punctuate, lbracket + , rbracket, vsep, (<+>), indent, lbrace, rbrace + , line, sep, hcat, annotate + , unAnnotate, line', group, nest + ) +import Data.Text.Prettyprint.Doc.Render.Terminal + ( color, colorDull, Color(..) + ) +import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle) +import Data.Scientific (Scientific) +import Data.String (IsString(..)) +import qualified Data.Text as T +import qualified Data.Vector as V +import GHC.Generics + +import Core.Data.Structures (Map, Key, fromMap, intoMap) +import Core.Text.Bytes (Bytes, intoBytes, fromBytes) +import Core.Text.Rope (Rope, Textual, intoRope, fromRope) +import Core.Text.Utilities (Render(..)) + +{-| +Given a JSON value, encode it to UTF-8 bytes + +I know we're not /supposed/ to rely on types to document functions, but +really, this one does what it says on the tin. +-} +encodeToUTF8 :: JsonValue -> Bytes +encodeToUTF8 = intoBytes . Aeson.encode . intoAeson + +{-| +Given an array of bytes, attempt to decode it as a JSON value. +-} +decodeFromUTF8 :: Bytes -> Maybe JsonValue +decodeFromUTF8 b = + let + x :: Maybe Aeson.Value + x = Aeson.decodeStrict' (fromBytes b) + in + fmap fromAeson x + +{-| +A JSON value. +-} +data JsonValue + = JsonObject (Map JsonKey JsonValue) + | JsonArray [JsonValue] + | JsonString Rope + | JsonNumber Scientific + | JsonBool Bool + | JsonNull + deriving (Eq, Show, Generic) + +-- +-- Overloads so that Haskell code literals can be interpreted as JSON +-- values. Obviously these are a lot on the partial side, but what else are +-- you supposed to do? This is all Haskell gives us for getting at +-- literals. +-- +instance IsString JsonValue where + fromString :: String -> JsonValue + fromString = JsonString . intoRope + +instance Num JsonValue where + fromInteger = JsonNumber . fromInteger + (+) = error "Sorry, you can't add JsonValues" + (-) = error "Sorry, you can't negate JsonValues" + (*) = error "Sorry, you can't multiply JsonValues" + abs = error "Sorry, not applicable for JsonValues" + signum = error "Sorry, not applicable for JsonValues" + +instance Fractional JsonValue where + fromRational :: Rational -> JsonValue + fromRational = JsonNumber . fromRational + (/) = error "Sorry, you can't do division on JsonValues" + + +intoAeson :: JsonValue -> Aeson.Value +intoAeson value = case value of + JsonObject xm -> + let + kvs = fromMap xm + tvs = fmap (\(k, v) -> (fromRope (coerce k), intoAeson v)) kvs + tvm :: HashMap T.Text Aeson.Value + tvm = HashMap.fromList tvs + in + Aeson.Object tvm + + JsonArray xs -> + let + vs = fmap intoAeson xs + in + Aeson.Array (V.fromList vs) + + JsonString x -> Aeson.String (fromRope x) + JsonNumber x -> Aeson.Number x + JsonBool x -> Aeson.Bool x + JsonNull -> Aeson.Null + +{-| + Keys in a JSON object. +-} +newtype JsonKey + = JsonKey Rope + deriving (Eq, Show, Generic, IsString, Ord) + +instance Hashable JsonKey +instance Key JsonKey + + +-- FIXME what is this instance? +instance Aeson.ToJSON Rope where + toJSON text = Aeson.toJSON (fromRope text :: T.Text) -- BAD + +instance Textual JsonKey where + fromRope t = coerce t + intoRope x = coerce x + + +fromAeson :: Aeson.Value -> JsonValue +fromAeson value = case value of + Aeson.Object o -> + let + tvs = HashMap.toList o + kvs = fmap (\(k, v) -> (JsonKey (intoRope k), fromAeson v)) tvs + + kvm :: Map JsonKey JsonValue + kvm = intoMap kvs + in + JsonObject kvm + + Aeson.Array v -> JsonArray (fmap fromAeson (V.toList v)) + Aeson.String t -> JsonString (intoRope t) + Aeson.Number n -> JsonNumber n + Aeson.Bool x -> JsonBool x + Aeson.Null -> JsonNull + +-- +-- Pretty printing +-- + +data JsonToken + = SymbolToken + | QuoteToken + | KeyToken + | StringToken + | EscapeToken + | NumberToken + | BooleanToken + | LiteralToken + +instance Render JsonValue where + type Token JsonValue = JsonToken + colourize = colourizeJson + intoDocA = prettyValue + +instance Render JsonKey where + type Token JsonKey = JsonToken + colourize = colourizeJson + intoDocA = prettyKey + +instance Render Aeson.Value where + type Token Aeson.Value = JsonToken + colourize = colourizeJson + intoDocA = prettyValue . fromAeson + +-- +-- Ugh. If you want to experiment with narrower output, then: +-- +-- . layoutPretty (LayoutOptions {layoutPageWidth = AvailablePerLine 15 1.0}) . prettyValue +-- +{-| +Used by the 'Render' instance to turn symbolic annotations into ANSI colours annotations. +If you're curious, the render pipeline looks like: + +@ + render = 'intoText' . 'renderStrict' . 'reAnnotateS' 'colourize' + . 'layoutPretty' 'defaultLayoutOptions' . 'prettyValue' +@ +-} +colourizeJson :: JsonToken -> AnsiStyle +colourizeJson token = case token of + SymbolToken -> color Black + QuoteToken -> color Black + KeyToken -> color Blue + StringToken -> colorDull Cyan + EscapeToken -> colorDull Yellow + NumberToken -> colorDull Green + BooleanToken -> color Magenta + LiteralToken -> colorDull Blue + + +instance Pretty JsonKey where + pretty = unAnnotate . prettyKey + +prettyKey :: JsonKey -> Doc JsonToken +prettyKey (JsonKey t) = + annotate QuoteToken dquote <> + annotate KeyToken (pretty (fromRope t :: T.Text)) <> + annotate QuoteToken dquote + +instance Pretty JsonValue where + pretty = unAnnotate . prettyValue + +prettyValue :: JsonValue -> Doc JsonToken +prettyValue value = case value of + JsonObject xm -> + let + pairs = fromMap xm + entries = fmap (\(k, v) -> (prettyKey k) <> annotate SymbolToken ":" <+> clear v (prettyValue v)) pairs + + clear v doc = case v of + (JsonObject _) -> line <> doc + (JsonArray _) -> group doc + _ -> doc + in + if length entries == 0 + then annotate SymbolToken (lbrace <> rbrace) + else annotate SymbolToken lbrace <> line <> indent 4 (vsep (punctuate (annotate SymbolToken comma) entries)) <> line <> annotate SymbolToken rbrace + + JsonArray xs -> + let + entries = fmap prettyValue xs + in + line' <> + nest 4 ( + annotate SymbolToken lbracket <> -- first line not indented + line' <> + sep (punctuate (annotate SymbolToken comma) entries) + ) <> + line' <> + annotate SymbolToken rbracket + + JsonString x -> + annotate QuoteToken dquote <> + annotate StringToken (escapeText x) <> + annotate QuoteToken dquote + + JsonNumber x -> annotate NumberToken (viaShow x) + + JsonBool x -> case x of + True -> annotate BooleanToken "true" + False -> annotate BooleanToken "false" + + JsonNull -> annotate LiteralToken "null" +{-# INLINEABLE prettyValue #-} + +escapeText :: Rope -> Doc JsonToken +escapeText text = + let + t = fromRope text :: T.Text + ts = T.split (== '"') t + ds = fmap pretty ts + in + hcat (punctuate (annotate EscapeToken "\\\"") ds) +{-# INLINEABLE escapeText #-} +