diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/core-data.cabal b/core-data.cabal --- a/core-data.cabal +++ b/core-data.cabal @@ -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 maintainer: Andrew Cowie -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 diff --git a/lib/Core/Data.hs b/lib/Core/Data.hs --- a/lib/Core/Data.hs +++ b/lib/Core/Data.hs @@ -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 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 @@ -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) diff --git a/lib/Core/Encoding.hs b/lib/Core/Encoding.hs --- a/lib/Core/Encoding.hs +++ b/lib/Core/Encoding.hs @@ -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 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 @@ -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 #-}