core-data 0.2.1.9 → 0.2.1.10
raw patch · 6 files changed
+441/−432 lines, 6 filesdep ~core-textPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: core-text
API changes (from Hackage documentation)
Files
- LICENSE +16/−29
- core-data.cabal +8/−7
- lib/Core/Data.hs +12/−11
- lib/Core/Data/Structures.hs +174/−160
- lib/Core/Encoding.hs +19/−19
- lib/Core/Encoding/Json.hs +212/−206
LICENSE view
@@ -1,32 +1,19 @@-Opinionated Haskell Interoperability--Copyright © 2018-2019 Athae Eredh Siniath 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:+Copyright © 2018-2021 Athae Eredh Siniath and Others - 1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.+Permission is hereby granted, free of charge, to any person obtaining a+copy of this software and associated documentation files (the "Software"),+to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense,+and/or sell copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following conditions: - 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.+The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software. -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.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER+DEALINGS IN THE SOFTWARE.
core-data.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: 3017ab753798627f979cfcb7b7382d12e5839ce8fdbd76a0e71c9673521ff98a+-- hash: 48545a1876c96d75c06bc415c0242e002b50e6b6e6c184b90e8aafebc9ee6bbf name: core-data-version: 0.2.1.9+version: 0.2.1.10 synopsis: Convenience wrappers around common data structures and encodings description: Wrappers around common data structures and encodings. .@@ -23,10 +23,11 @@ bug-reports: https://github.com/aesiniath/unbeliever/issues author: Andrew Cowie <istathar@gmail.com> maintainer: Andrew Cowie <istathar@gmail.com>-copyright: © 2018-2020 Athae Eredh Siniath and Others-license: BSD3+copyright: © 2018-2021 Athae Eredh Siniath and Others+license: MIT license-file: LICENSE-tested-with: GHC == 8.8.4+tested-with:+ GHC == 8.10.7 build-type: Simple source-repository head@@ -47,7 +48,7 @@ , base >=4.11 && <5 , bytestring , containers- , core-text >=0.3.0+ , core-text >=0.3.4 , hashable >=1.2 && <1.4 , prettyprinter >=1.6.2 , scientific
lib/Core/Data.hs view
@@ -1,16 +1,17 @@ {-# 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
lib/Core/Data/Structures.hs view
@@ -3,12 +3,13 @@ {-# 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.-module Core.Data.Structures- ( -- * Map type+{- |+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,@@ -33,8 +34,7 @@ Key, unMap, unSet,- )-where+) where import Core.Text.Bytes (Bytes) import Core.Text.Rope (Rope)@@ -52,40 +52,42 @@ -- 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@@ -105,72 +107,78 @@ 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+ 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.+{- |+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@@ -184,131 +192,137 @@ -- 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) 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) 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)+ 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)+ 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)+{- |+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" 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" 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)
lib/Core/Encoding.hs view
@@ -1,23 +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.-module Core.Encoding- ( module Core.Encoding.Json,- )-where+{- |+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
lib/Core/Encoding/Json.hs view
@@ -14,88 +14,71 @@ -- efficient emitter. -- --- |--- 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+{- |+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 (..), -- * 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+) 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 Core.Text.Utilities (+ AnsiColour,+ Render (Token, colourize, highlight),+ brightBlue,+ brightGrey,+ brightMagenta,+ dullBlue,+ dullCyan,+ dullGreen,+ dullYellow,+ pureGrey,+ ) import qualified Data.Aeson as Aeson import Data.Coerce import Data.HashMap.Strict (HashMap)@@ -104,8 +87,10 @@ import Data.Scientific (Scientific) import Data.String (IsString (..)) import qualified Data.Text as T-import Data.Text.Prettyprint.Doc- ( Doc,+import qualified Data.Vector as V+import GHC.Generics+import Prettyprinter (+ Doc, Pretty (..), annotate, comma,@@ -126,36 +111,37 @@ viaShow, vsep, (<+>),- )-import qualified Data.Vector as V-import GHC.Generics+ ) --- |--- 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@@ -164,43 +150,44 @@ -- 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 @@ -208,55 +195,73 @@ -- 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+ 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+ 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 -- +{- |+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+}+@+-} 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- highlight = prettyValue+ type Token JsonValue = JsonToken+ colourize = colourizeJson+ highlight = prettyValue instance Render JsonKey where- type Token JsonKey = JsonToken- colourize = colourizeJson- highlight = prettyKey+ type Token JsonKey = JsonToken+ colourize = colourizeJson+ highlight = prettyKey instance Render Aeson.Value where- type Token Aeson.Value = JsonToken- colourize = colourizeJson- highlight = prettyValue . fromAeson+ type Token Aeson.Value = JsonToken+ colourize = colourizeJson+ highlight = prettyValue . fromAeson -- -- Ugh. If you want to experiment with narrower output, then:@@ -264,76 +269,77 @@ -- . 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'--- @+{- |+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 -> brightGrey- QuoteToken -> brightGrey- KeyToken -> brightBlue- StringToken -> dullCyan- EscapeToken -> dullYellow- NumberToken -> dullGreen- BooleanToken -> brightMagenta- LiteralToken -> dullBlue+ SymbolToken -> pureGrey+ 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+ 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- <> 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"+ 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 #-}