diff --git a/core-data.cabal b/core-data.cabal --- a/core-data.cabal +++ b/core-data.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 5d521b5fb71438aae3360db9b1e59766f97c85fcae21b87e0a2ae9809a866820 +-- hash: 3017ab753798627f979cfcb7b7382d12e5839ce8fdbd76a0e71c9673521ff98a name: core-data -version: 0.2.1.8 +version: 0.2.1.9 synopsis: Convenience wrappers around common data structures and encodings description: Wrappers around common data structures and encodings. . @@ -26,7 +26,7 @@ copyright: © 2018-2020 Athae Eredh Siniath and Others license: BSD3 license-file: LICENSE -tested-with: GHC == 8.8.3 +tested-with: GHC == 8.8.4 build-type: Simple source-repository head @@ -47,10 +47,9 @@ , base >=4.11 && <5 , bytestring , containers - , core-text >=0.2.2 + , core-text >=0.3.0 , hashable >=1.2 && <1.4 - , prettyprinter >=1.2.1.1 && <1.8 - , prettyprinter-ansi-terminal + , prettyprinter >=1.6.2 , scientific , text , unordered-containers diff --git a/lib/Core/Data.hs b/lib/Core/Data.hs --- a/lib/Core/Data.hs +++ b/lib/Core/Data.hs @@ -1,26 +1,24 @@ {-# 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. --} +-- | +-- 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 + ( -- * Wrappers -import Core.Data.Structures + -- | + -- 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 --- a/lib/Core/Data/Structures.hs +++ b/lib/Core/Data/Structures.hs @@ -1,181 +1,176 @@ -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# 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. --} +-- | +-- 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 + ( -- * Map type + Map, + emptyMap, + singletonMap, + insertKeyValue, + containsKey, + lookupKeyValue, - {-* Conversions -} - , Dictionary(K, V, fromMap, intoMap) + -- * Conversions + Dictionary (K, V, fromMap, intoMap), - {-* Set type -} - , Set - , emptySet - , singletonSet - , insertElement - , containsElement + -- * Set type + Set, + emptySet, + singletonSet, + insertElement, + containsElement, - {-* Conversions -} - , Collection(E, fromSet, intoSet) + -- * Conversions + Collection (E, fromSet, intoSet), - {-* Internals -} - , Key - , unMap - , unSet -) + -- * Internals + Key, + unMap, + unSet, + ) where +import Core.Text.Bytes (Bytes) +import Core.Text.Rope (Rope) import qualified Data.ByteString as B (ByteString) -import Data.Foldable (Foldable(..)) -import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet +import Data.Hashable (Hashable) 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) +import qualified GHC.Exts as Exts (IsList (..)) -- 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) --} +-- | +-- 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) + 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. --} +-- | +-- 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 Key B.ByteString 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 + 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. --} +-- | +-- A dictionary with no key/value mappings. emptyMap :: Map κ ν emptyMap = Map (HashMap.empty) -{-| -Construct a dictionary with only a single key/value pair. --} +-- | +-- 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. --} +-- | +-- 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. --} +-- | +-- 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? --} +-- | +-- 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) + (<>) (Map u1) (Map u2) = Map (HashMap.union u1 u2) instance Key κ => Monoid (Map κ ν) where - mempty = emptyMap - mappend = (<>) + 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 + type Item (Map κ ν) = (κ, ν) + fromList pairs = Map (HashMap.fromList pairs) + toList (Map u) = HashMap.toList u - list :: [('Rope','Int')] - list = 'fromMap' answers -@ +-- | +-- 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. -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 @@ -189,137 +184,131 @@ -- Many thanks for an elegant solution to the problem. -- class Dictionary α where - type K α :: * - type V α :: * - fromMap :: Map (K α) (V α) -> α - intoMap :: α -> Map (K α) (V α) + 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 + type K (Map κ ν) = κ + type V (Map κ ν) = ν + fromMap = id + intoMap = id -{-| from "Data.HashMap.Strict" (and .Lazy) -} +-- | 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 + type K (HashMap.HashMap κ ν) = κ + type V (HashMap.HashMap κ ν) = ν + fromMap (Map u) = u + intoMap u = Map u -{-| from "Data.Map.Strict" (and .Lazy) -} +-- | 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. + 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) -To convert to other collection types see 'fromSet' below. +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) -(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) --} +-- | +-- 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) + 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 + 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) + (<>) (Set u1) (Set u2) = Set (HashSet.union u1 u2) instance Key ε => Monoid (Set ε) where - mempty = emptySet - mappend = (<>) + mempty = emptySet + mappend = (<>) -{-| -An empty collection. This is used for example as an inital value when -building up a 'Set' using a fold. --} +-- | +-- 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. --} +-- | +-- 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. --} +-- | +-- 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? --} +-- | +-- 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. --} +-- | +-- 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 α) + type E α :: * + fromSet :: Set (E α) -> α + intoSet :: α -> Set (E α) instance Key ε => Collection (Set ε) where - type E (Set ε) = ε - fromSet = id - intoSet = id + type E (Set ε) = ε + fromSet = id + intoSet = id -{-| from "Data.HashSet" -} +-- | from "Data.HashSet" instance Key ε => Collection (HashSet.HashSet ε) where - type E (HashSet.HashSet ε) = ε - fromSet (Set u) = u - intoSet u = Set u + type E (HashSet.HashSet ε) = ε + fromSet (Set u) = u + intoSet u = Set u -{-| from "Data.Set" -} +-- | 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) + 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) + 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 --- a/lib/Core/Encoding.hs +++ b/lib/Core/Encoding.hs @@ -1,26 +1,23 @@ {-# 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. - --} +-- | +-- 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 + ( module Core.Encoding.Json, + ) +where import Core.Encoding.Json - diff --git a/lib/Core/Encoding/Json.hs b/lib/Core/Encoding/Json.hs --- a/lib/Core/Encoding/Json.hs +++ b/lib/Core/Encoding/Json.hs @@ -1,48 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} {-# 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 @@ -50,95 +13,149 @@ -- 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: +-- | +-- 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. +module Core.Encoding.Json + ( -- * Encoding and Decoding + encodeToUTF8, + decodeFromUTF8, + JsonValue (..), + JsonKey (..), -@ -23:46:04Z (00000.007) j = -{ - "answer": 42.0 -} -@ + -- * Syntax highlighting --} - , JsonToken(..) - , colourizeJson - , prettyKey - , prettyValue - ) where + -- | + -- 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 Core.Data.Structures (Key, Map, fromMap, intoMap) +import Core.Text.Bytes (Bytes, fromBytes, intoBytes) +import Core.Text.Rope (Rope, Textual, fromRope, intoRope) +import Core.Text.Utilities + ( brightBlue, + brightGrey, + brightMagenta, + dullBlue, + dullCyan, + dullGreen, + dullYellow, + AnsiColour, + Render(Token, highlight, colourize) ) 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 Data.String (IsString (..)) import qualified Data.Text as T +import Data.Text.Prettyprint.Doc + ( Doc, + Pretty (..), + annotate, + comma, + dquote, + group, + hcat, + indent, + lbrace, + lbracket, + line, + line', + nest, + punctuate, + rbrace, + rbracket, + sep, + unAnnotate, + viaShow, + vsep, + (<+>), + ) 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. --} +-- | +-- 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. --} +-- | +-- 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 + let x :: Maybe Aeson.Value + x = Aeson.decodeStrict' (fromBytes b) + in fmap fromAeson x -{-| -A JSON value. --} +-- | +-- A JSON value. data JsonValue - = JsonObject (Map JsonKey JsonValue) - | JsonArray [JsonValue] - | JsonString Rope - | JsonNumber Scientific - | JsonBool Bool - | JsonNull - deriving (Eq, Show, Generic) + = 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 @@ -147,200 +164,176 @@ -- literals. -- instance IsString JsonValue where - fromString :: String -> JsonValue - fromString = JsonString . intoRope + 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" + 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" - + 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 + 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. --} +-- | +-- Keys in a JSON object. newtype JsonKey - = JsonKey Rope - deriving (Eq, Show, Generic, IsString, Ord) + = JsonKey Rope + deriving (Eq, Show, Generic, IsString, Ord) instance Hashable JsonKey -instance Key JsonKey +instance Key JsonKey -- FIXME what is this instance? instance Aeson.ToJSON Rope where - toJSON text = Aeson.toJSON (fromRope text :: T.Text) -- BAD + toJSON text = Aeson.toJSON (fromRope text :: T.Text) -- BAD instance Textual JsonKey where - fromRope t = coerce t - intoRope x = coerce x - + 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.Object o -> + let tvs = HashMap.toList o + kvs = fmap (\(k, v) -> (JsonKey (intoRope k), fromAeson v)) tvs - 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 + 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 + = SymbolToken + | QuoteToken + | KeyToken + | StringToken + | EscapeToken + | NumberToken + | BooleanToken + | LiteralToken instance Render JsonValue where - type Token JsonValue = JsonToken - colourize = colourizeJson - intoDocA = prettyValue + type Token JsonValue = JsonToken + colourize = colourizeJson + highlight = prettyValue instance Render JsonKey where - type Token JsonKey = JsonToken - colourize = colourizeJson - intoDocA = prettyKey + type Token JsonKey = JsonToken + colourize = colourizeJson + highlight = prettyKey instance Render Aeson.Value where - type Token Aeson.Value = JsonToken - colourize = colourizeJson - intoDocA = prettyValue . fromAeson + type Token Aeson.Value = JsonToken + colourize = colourizeJson + highlight = 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 +-- | +-- 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 -> AnsiColour 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 - + SymbolToken -> brightGrey + QuoteToken -> brightGrey + KeyToken -> brightBlue + StringToken -> dullCyan + EscapeToken -> dullYellow + NumberToken -> dullGreen + BooleanToken -> brightMagenta + LiteralToken -> dullBlue instance Pretty JsonKey where - pretty = unAnnotate . prettyKey + pretty = unAnnotate . prettyKey prettyKey :: JsonKey -> Doc JsonToken prettyKey (JsonKey t) = - annotate QuoteToken dquote <> - annotate KeyToken (pretty (fromRope t :: T.Text)) <> - annotate QuoteToken dquote + annotate QuoteToken dquote + <> annotate KeyToken (pretty (fromRope t :: T.Text)) + <> annotate QuoteToken dquote instance Pretty JsonValue where - pretty = unAnnotate . prettyValue + 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" + JsonObject xm -> + let pairs = fromMap xm + entries = fmap (\(k, v) -> (prettyKey k) <> annotate SymbolToken ":" <+> clear v (prettyValue v)) pairs - JsonNull -> annotate LiteralToken "null" + 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 + <> line' -- first line not indented + <> 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) + let t = fromRope text :: T.Text + ts = T.split (== '"') t + ds = fmap pretty ts + in hcat (punctuate (annotate EscapeToken "\\\"") ds) {-# INLINEABLE escapeText #-} -