diff options
Diffstat (limited to 'users/Profpatsch/my-prelude/src')
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Json.hs | 258 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Json/Enc.hs | 272 |
2 files changed, 530 insertions, 0 deletions
diff --git a/users/Profpatsch/my-prelude/src/Json.hs b/users/Profpatsch/my-prelude/src/Json.hs new file mode 100644 index 000000000000..3738ec6adfff --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Json.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +module Json where + +import Data.Aeson (FromJSON (parseJSON), ToJSON (toEncoding, toJSON), Value (..), withObject) +import Data.Aeson qualified as Json +import Data.Aeson.BetterErrors qualified as Json +import Data.Aeson.Types qualified +import Data.Error.Tree +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Time (UTCTime) +import Data.Vector qualified as Vector +import FieldParser (FieldParser) +import FieldParser qualified as Field +import Label +import PossehlAnalyticsPrelude + +-- | Use a "Data.Aeson.BetterErrors" parser to implement 'FromJSON'’s 'parseJSON' method. +-- +-- @ +-- instance FromJSON Foo where +-- parseJSON = Json.toParseJSON parseFoo +-- @ +toParseJSON :: + -- | the error type is 'Error', if you need 'ErrorTree' use 'toParseJSONErrorTree' + Json.Parse Error a -> + Value -> + Data.Aeson.Types.Parser a +toParseJSON = Json.toAesonParser prettyError + +-- | Use a "Data.Aeson.BetterErrors" parser to implement 'FromJSON'’s 'parseJSON' method. +-- +-- @ +-- instance FromJSON Foo where +-- parseJSON = Json.toParseJSON parseFoo +-- @ +toParseJSONErrorTree :: + -- | the error type is 'ErrorTree', if you need 'Error' use 'toParseJSON' + Json.Parse ErrorTree a -> + Value -> + Data.Aeson.Types.Parser a +toParseJSONErrorTree = Json.toAesonParser prettyErrorTree + +-- | Convert a 'Json.ParseError' to a corresponding 'ErrorTree' +-- +-- TODO: build a different version of 'Json.displayError' so that we can nest 'ErrorTree' as well +parseErrorTree :: Error -> Json.ParseError ErrorTree -> ErrorTree +parseErrorTree contextMsg errs = + errs + & Json.displayError prettyErrorTree + & Text.intercalate "\n" + & newError + -- We nest this here because the json errors is multiline, so the result looks like + -- + -- @ + -- contextMsg + -- \| + -- `- At the path: ["foo"]["bar"] + -- Type mismatch: + -- Expected a value of type object + -- Got: true + -- @ + & singleError + & nestedError contextMsg + +-- | Lift the parser error to an error tree +asErrorTree :: (Functor m) => Json.ParseT Error m a -> Json.ParseT ErrorTree m a +asErrorTree = Json.mapError singleError + +-- | Parse the json array into a 'Set'. +asArraySet :: + (Ord a, Monad m) => + Json.ParseT err m a -> + Json.ParseT err m (Set a) +asArraySet inner = Set.fromList <$> Json.eachInArray inner + +-- | Parse the json object into a 'Map'. +asObjectMap :: + (Monad m) => + Json.ParseT err m a -> + Json.ParseT err m (Map Text a) +asObjectMap inner = Map.fromList <$> Json.eachInObject inner + +-- | Parse as json array and count the number of elements in the array. +countArrayElements :: (Monad m) => Json.ParseT Error m Natural +countArrayElements = Field.toJsonParser ((jsonArray <&> Vector.length) >>> Field.integralToNatural) + where + -- I don’t want to add this to the FieldParser module, cause users should not be dealing with arrays manually. + jsonArray :: FieldParser Json.Value (Vector Json.Value) + jsonArray = Field.FieldParser $ \case + Json.Array vec -> Right vec + _ -> Left "Not a json array" + +-- | Parse as json number and convert it to a 'Double'. Throws an error if the number does not fit into a 'Double'. +asDouble :: (Monad m) => Json.ParseT Error m Double +asDouble = + Field.toJsonParser + ( Field.jsonNumber + >>> Field.boundedScientificRealFloat @Double + ) + +asInt :: (Monad m) => Json.ParseT Error m Int +asInt = + Field.toJsonParser + ( Field.jsonNumber + >>> Field.boundedScientificIntegral @Int "Cannot parse into Int" + ) + +-- | Json string containing a UTC timestamp, +-- @yyyy-mm-ddThh:mm:ss[.sss]Z@ (ISO 8601:2004(E) sec. 4.3.2 extended format) +asUtcTime :: (Monad m) => Json.ParseT Error m UTCTime +asUtcTime = Field.toJsonParser (Field.jsonString >>> Field.utcTime) + +-- | Json string containing a UTC timestamp. +-- | Accepts multiple timezone formats. +-- Do not use this if you can force the input to use the `Z` UTC notation (e.g. in a CSV), use 'utcTime' instead. +-- +-- Accepts +-- +-- * UTC timestamps: @yyyy-mm-ddThh:mm:ss[.sss]Z@ +-- * timestamps with time zone: @yyyy-mm-ddThh:mm:ss[.sss]±hh:mm@ +-- +-- ( both ISO 8601:2004(E) sec. 4.3.2 extended format) +-- +-- The time zone of the second kind of timestamp is taken into account, but normalized to UTC (it’s not preserved what the original time zone was) +asUtcTimeLenient :: (Monad m) => Json.ParseT Error m UTCTime +asUtcTimeLenient = Field.toJsonParser (Field.jsonString >>> Field.utcTimeLenient) + +-- | Parse a key from the object, à la 'Json.key', return a labelled value. +-- +-- We don’t provide a version that infers the json object key, +-- since that conflates internal naming with the external API, which is dangerous. +-- +-- @@ +-- do +-- txt <- keyLabel @"myLabel" "jsonKeyName" Json.asText +-- pure (txt :: Label "myLabel" Text) +-- @@ +keyLabel :: + forall label err m a. + (Monad m) => + Text -> + Json.ParseT err m a -> + Json.ParseT err m (Label label a) +keyLabel = do + keyLabel' (Proxy @label) + +-- | Parse a key from the object, à la 'Json.key', return a labelled value. +-- Version of 'keyLabel' that requires a proxy. +-- +-- @@ +-- do +-- txt <- keyLabel' (Proxy @"myLabel") "jsonKeyName" Json.asText +-- pure (txt :: Label "myLabel" Text) +-- @@ +keyLabel' :: + forall label err m a. + (Monad m) => + Proxy label -> + Text -> + Json.ParseT err m a -> + Json.ParseT err m (Label label a) +keyLabel' Proxy key parser = label @label <$> Json.key key parser + +-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value. +-- +-- We don’t provide a version that infers the json object key, +-- since that conflates internal naming with the external API, which is dangerous. +-- +-- @@ +-- do +-- txt <- keyLabelMay @"myLabel" "jsonKeyName" Json.asText +-- pure (txt :: Label "myLabel" (Maybe Text)) +-- @@ +keyLabelMay :: + forall label err m a. + (Monad m) => + Text -> + Json.ParseT err m a -> + Json.ParseT err m (Label label (Maybe a)) +keyLabelMay = do + keyLabelMay' (Proxy @label) + +-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value. +-- Version of 'keyLabelMay' that requires a proxy. +-- +-- @@ +-- do +-- txt <- keyLabelMay' (Proxy @"myLabel") "jsonKeyName" Json.asText +-- pure (txt :: Label "myLabel" (Maybe Text)) +-- @@ +keyLabelMay' :: + forall label err m a. + (Monad m) => + Proxy label -> + Text -> + Json.ParseT err m a -> + Json.ParseT err m (Label label (Maybe a)) +keyLabelMay' Proxy key parser = label @label <$> Json.keyMay key parser + +-- NOTE: keyRenamed Test in "Json.JsonTest", due to import cycles. + +-- | Like 'Json.key', but allows a list of keys that are tried in order. +-- +-- This is intended for renaming keys in an object. +-- The first key is the most up-to-date version of a key, the others are for backward-compatibility. +-- +-- If a key (new or old) exists, the inner parser will always be executed for that key. +keyRenamed :: (Monad m) => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m a +keyRenamed (newKey :| oldKeys) inner = + keyRenamedTryOldKeys oldKeys inner >>= \case + Nothing -> Json.key newKey inner + Just parse -> parse + +-- | Like 'Json.keyMay', but allows a list of keys that are tried in order. +-- +-- This is intended for renaming keys in an object. +-- The first key is the most up-to-date version of a key, the others are for backward-compatibility. +-- +-- If a key (new or old) exists, the inner parser will always be executed for that key. +keyRenamedMay :: (Monad m) => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m (Maybe a) +keyRenamedMay (newKey :| oldKeys) inner = + keyRenamedTryOldKeys oldKeys inner >>= \case + Nothing -> Json.keyMay newKey inner + Just parse -> Just <$> parse + +-- | Helper function for 'keyRenamed' and 'keyRenamedMay' that returns the parser for the first old key that exists, if any. +keyRenamedTryOldKeys :: (Monad m) => [Text] -> Json.ParseT err m a -> Json.ParseT err m (Maybe (Json.ParseT err m a)) +keyRenamedTryOldKeys oldKeys inner = do + oldKeys & traverse tryOld <&> catMaybes <&> nonEmpty <&> \case + Nothing -> Nothing + Just (old :| _moreOld) -> Just old + where + tryOld key = + Json.keyMay key (pure ()) <&> \case + Just () -> Just $ Json.key key inner + Nothing -> Nothing + +-- | A simple type isomorphic to `()` that that transforms to an empty json object and parses +data EmptyObject = EmptyObject + deriving stock (Show, Eq) + +instance FromJSON EmptyObject where + -- allow any fields, as long as its an object + parseJSON = withObject "EmptyObject" (\_ -> pure EmptyObject) + +instance ToJSON EmptyObject where + toJSON EmptyObject = Object mempty + toEncoding EmptyObject = toEncoding $ Object mempty + +-- | Create a json array from a list of json values. +mkJsonArray :: [Value] -> Value +mkJsonArray xs = xs & Vector.fromList & Array diff --git a/users/Profpatsch/my-prelude/src/Json/Enc.hs b/users/Profpatsch/my-prelude/src/Json/Enc.hs new file mode 100644 index 000000000000..c7cd6e4635e0 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Json/Enc.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuasiQuotes #-} + +module Json.Enc where + +import Data.Aeson (Encoding, Value (..)) +import Data.Aeson qualified as Json +import Data.Aeson.Encode.Pretty qualified as Aeson.Pretty +import Data.Aeson.Encoding qualified as AesonEnc +import Data.Aeson.Encoding qualified as Json.Enc +import Data.Aeson.Encoding qualified as Json.Encoding +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Base64 qualified as Base64 +import Data.ByteString.Lazy qualified as LazyBytes +import Data.Containers.ListUtils (nubOrdOn) +import Data.Int (Int64) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Scientific +import Data.String (IsString (fromString)) +import Data.Text.Lazy qualified as Lazy +import Data.Text.Lazy.Builder qualified as Text.Builder +import Data.Time qualified as Time +import Data.Time.Format.ISO8601 qualified as ISO8601 +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import PossehlAnalyticsPrelude + +-- | A JSON encoder. +-- +-- It is faster than going through 'Value', because 'Encoding' is just a wrapper around a @Bytes.Builder@. +-- But the @aeson@ interface for 'Encoding' is extremely bad, so let’s build a better one. +newtype Enc = Enc {unEnc :: Encoding} + deriving (Num, Fractional) via (NumLiteralOnly "Enc" Enc) + +instance Show Enc where + show e = e.unEnc & Json.Encoding.encodingToLazyByteString & bytesToTextUtf8UnsafeLazy & show + +-- | You can create an @Enc any@ that renders a json string value with @OverloadedStrings@. +instance IsString Enc where + fromString = Enc . AesonEnc.string + +-- | You can create an @Enc any@ that renders a json number value with an integer literal. +instance IntegerLiteral Enc where + integerLiteral = Enc . AesonEnc.integer + +-- | You can create an @Enc any@ that renders a json number value with an floating point literal. +-- +-- __ATTN__: Bear in mind that this will crash on repeating rationals, so only use for literals in code! +instance RationalLiteral Enc where + rationalLiteral r = Enc $ AesonEnc.scientific (r & fromRational @Scientific) + +-- | Convert an 'Enc' to a strict UTF8-bytestring which is valid JSON (minified). +encToBytesUtf8 :: Enc -> ByteString +encToBytesUtf8 enc = enc & encToBytesUtf8Lazy & toStrictBytes + +-- | Convert an 'Enc' to a lazy UTF8-bytestring which is valid JSON (minified). +encToBytesUtf8Lazy :: Enc -> LazyBytes.ByteString +encToBytesUtf8Lazy enc = enc.unEnc & Json.Enc.encodingToLazyByteString + +-- | Convert an 'Enc' to a strict Text which is valid JSON (prettyfied). +-- +-- __ATTN__: will re-parse the json through 'Json.Value', so only use for user-interactions like pretty-printing. +encToTextPretty :: Enc -> Text +encToTextPretty enc = + enc + & encToTextPrettyLazy + & toStrict + +-- | Convert an 'Enc' to a lazy Text which is valid JSON (prettyfied). +-- +-- __ATTN__: will re-parse the json through 'Json.Value', so only use for user-interactions like pretty-printing. +encToTextPrettyLazy :: Enc -> Lazy.Text +encToTextPrettyLazy enc = + enc + & encToBytesUtf8Lazy + & Json.decode @Json.Value + & annotate "the json parser can’t parse json encodings??" + & unwrapError + & Aeson.Pretty.encodePrettyToTextBuilder + & Text.Builder.toLazyText + +-- | Embed a 'Json.Encoding' verbatim (it’s a valid JSON value) +encoding :: Encoding -> Enc +encoding = Enc + +-- | Encode a 'Json.Value' verbatim (it’s a valid JSON value) +value :: Value -> Enc +value = Enc . AesonEnc.value + +-- | Encode an empty json list +emptyArray :: Enc +emptyArray = Enc AesonEnc.emptyArray_ + +-- | Encode an empty json dict +emptyObject :: Enc +emptyObject = Enc AesonEnc.emptyObject_ + +-- | Encode a 'Text' as a json string +text :: Text -> Enc +text = Enc . AesonEnc.text + +-- | Encode a lazy 'Text' as a json string +lazyText :: Lazy.Text -> Enc +lazyText = Enc . AesonEnc.lazyText + +-- | Encode a 'ByteString' as a base64-encoded json string +base64Bytes :: ByteString -> Enc +base64Bytes = Enc . AesonEnc.text . bytesToTextUtf8Unsafe . Base64.encode + +-- | Encode a 'Text' as a base64-encoded json string +base64 :: Text -> Enc +base64 = Enc . AesonEnc.text . bytesToTextUtf8Unsafe . Base64.encode . textToBytesUtf8 + +-- | Encode a 'Prelude.String' as a json string +string :: String -> Enc +string = Enc . AesonEnc.string + +-- | Encode as json @null@ if 'Nothing', else use the given encoder for @Just a@ +nullOr :: (a -> Enc) -> Maybe a -> Enc +nullOr inner = \case + Nothing -> Enc AesonEnc.null_ + Just a -> inner a + +-- | Encode a list as a json list +list :: (a -> Enc) -> [a] -> Enc +list f = Enc . AesonEnc.list (\a -> (f a).unEnc) + +-- | Encode a 'NonEmpty' as a json list. +nonEmpty :: (a -> Enc) -> NonEmpty a -> Enc +nonEmpty f = list f . toList + +-- | Encode the given list of keys and their encoders as json dict. +-- +-- If the list contains the same key multiple times, the first value in the list is retained: +-- +-- @ +-- (object [ ("foo", 42), ("foo", 23) ]) +-- ~= "{\"foo\":42}" +-- @ +object :: (Foldable t) => t (Text, Enc) -> Enc +object m = + Enc $ + AesonEnc.dict + AesonEnc.text + (\recEnc -> recEnc.unEnc) + (\f -> List.foldr (\(k, v) -> f k v)) + (nubOrdOn fst $ toList m) + +-- | A tag/value encoder; See 'choice' +data Choice = Choice Text Enc + +-- | Encode a sum type as a @Choice@, an object with a @tag@/@value@ pair, +-- which is the conventional json sum type representation in our codebase. +-- +-- @ +-- foo :: Maybe Text -> Enc +-- foo = choice $ \case +-- Nothing -> Choice "no" emptyObject () +-- Just t -> Choice "yes" text t +-- +-- ex = foo Nothing == "{\"tag\": \"no\", \"value\": {}}" +-- ex2 = foo (Just "hi") == "{\"tag\": \"yes\", \"value\": \"hi\"}" +-- @ +choice :: (from -> Choice) -> from -> Enc +choice f from = case f from of + Choice key encA -> singleChoice key encA + +-- | Like 'choice', but simply encode a single possibility into a @tag/value@ object. +-- This can be useful, but if you want to match on an enum, use 'choice' instead. +singleChoice :: Text -> Enc -> Enc +singleChoice key encA = + Enc $ + AesonEnc.pairs $ + mconcat + [ AesonEnc.pair "tag" (AesonEnc.text key), + AesonEnc.pair "value" encA.unEnc + ] + +-- | Encode a 'Map' as a json dict +-- +-- We can’t really set the key to anything but text (We don’t keep the tag of 'Encoding') +-- so instead we allow anything that’s coercible from text as map key (i.e. newtypes). +map :: forall k v. (Coercible k Text) => (v -> Enc) -> Map k v -> Enc +map valEnc m = + Enc $ + AesonEnc.dict + (AesonEnc.text . coerce @k @Text) + (\v -> (valEnc v).unEnc) + Map.foldrWithKey + m + +-- | Encode a 'KeyMap' as a json dict +keyMap :: (v -> Enc) -> KeyMap v -> Enc +keyMap valEnc m = + Enc $ + AesonEnc.dict + (AesonEnc.text . Key.toText) + (\v -> (valEnc v).unEnc) + KeyMap.foldrWithKey + m + +-- | Encode 'Json.Null' +null :: Enc +null = Enc AesonEnc.null_ + +-- | Encode a 'Prelude.Bool' as a json boolean +bool :: Bool -> Enc +bool = Enc . AesonEnc.bool + +-- | Encode an 'Integer' as a json number. +-- TODO: is it okay to just encode an arbitrarily-sized integer into json? +integer :: Integer -> Enc +integer = Enc . AesonEnc.integer + +-- | Encode a 'Scientific' as a json number. +scientific :: Scientific -> Enc +scientific = Enc . AesonEnc.scientific + +-- | Encode a 'Natural' as a json number. +natural :: Natural -> Enc +natural = integer . toInteger @Natural + +-- | Encode an 'Int' as a json number. +int :: Int -> Enc +int = Enc . AesonEnc.int + +-- | Encode an 'Int64' as a json number. +int64 :: Int64 -> Enc +int64 = Enc . AesonEnc.int64 + +-- | Encode 'Time.UTCTime' as a json string, as an ISO8601 timestamp with timezone (@yyyy-mm-ddThh:mm:ss[.sss]Z@) +utcTime :: Time.UTCTime -> Enc +utcTime = + text . stringToText . ISO8601.iso8601Show @Time.UTCTime + +-- | Implement this class if you want your type to only implement the part of 'Num' +-- that allows creating them from Integer-literals, then derive Num via 'NumLiteralOnly': +-- +-- @ +-- data Foo = Foo Integer +-- deriving (Num) via (NumLiteralOnly "Foo" Foo) +-- +-- instance IntegerLiteral Foo where +-- integerLiteral i = Foo i +-- @ +class IntegerLiteral a where + integerLiteral :: Integer -> a + +-- | The same as 'IntegerLiteral' but for floating point literals. +class RationalLiteral a where + rationalLiteral :: Rational -> a + +-- | Helper class for @deriving (Num) via …@, implements only literal syntax for integer and floating point numbers, +-- and throws descriptive runtime errors for any other methods in 'Num'. +-- +-- See 'IntegerLiteral' and 'RationalLiteral' for examples. +newtype NumLiteralOnly (sym :: Symbol) num = NumLiteralOnly num + +instance (IntegerLiteral num, KnownSymbol sym) => Num (NumLiteralOnly sym num) where + fromInteger = NumLiteralOnly . integerLiteral + (+) = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to add (+) (NumLiteralOnly)|] + (*) = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to multiply (*) (NumLiteralOnly)|] + (-) = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to subtract (-) (NumLiteralOnly)|] + abs = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to use `abs` (NumLiteralOnly)|] + signum = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to use `signum` (NumLiteralOnly)|] + +instance (IntegerLiteral num, RationalLiteral num, KnownSymbol sym) => Fractional (NumLiteralOnly sym num) where + fromRational = NumLiteralOnly . rationalLiteral + recip = error [fmt|Only use as rational literal allowed for {symbolVal (Proxy @sym)}, you tried to use `recip` (NumLiteralOnly)|] + (/) = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to divide (/) (NumLiteralOnly)|] |