pa-json 0.3.0.0 → 0.4.0.0

raw patch · 3 files changed

+91/−3 lines, 3 filesdep +mono-traversable

Dependencies added: mono-traversable

Files

• CHANGELOG.md +7/−0
• pa-json.cabal +6/−1
• src/Json.hs +78/−2

@@ -1,5 +1,12 @@ # Revision history for pa-json +## 0.4.0.0 -- 2024-09-04++- Add `eachInArrayNonEmpty`+- Add `choice`, `choiceDef`, `choiceImpl`, `mkSingleChoice`+- Add `ensureNotEmpty`+- Add `mkUtcTime`, `mkMaybe`+ ## 0.3.0.0 -- 2023-10-15  - rename `jsonArray` to `mkJsonArray`

@@ -1,7 +1,7 @@ cabal-version:      3.0 -- !!! ATTN: file autogenerated from pa-template.cabal.mustache on toplevel !!! name:               pa-json-version:            0.3.0.0+version:            0.4.0.0 synopsis:           Our JSON parsers/encoders description:        The interface of `aeson` is unfortunately extremely … suboptimal. Here’s some wrappers trying to improve the situation, which we use internally. license:            BSD-3-Clause@@ -61,6 +61,10 @@     -- to enable the `type` keyword in import lists (ormolu uses this automatically)     ExplicitNamespaces +    -- allows defining pattern synonyms, but also the `import Foo (pattern FooPattern)` import syntax+    PatternSynonyms++   default-language: GHC2021  library@@ -83,6 +87,7 @@       bytestring,       base64-bytestring,       containers,+      mono-traversable,       scientific,       time,       text,

@@ -1,19 +1,22 @@-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE QuasiQuotes #-}  module Json where  import Data.Aeson (FromJSON (parseJSON), ToJSON (toEncoding, toJSON), Value (..), withObject) import Data.Aeson qualified as Json+import Data.Aeson.BetterErrors (throwCustomError) 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.MonoTraversable (MonoFoldable)+import Data.MonoTraversable qualified as MonoFoldable import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as Text import Data.Time (UTCTime)+import Data.Time.Format.ISO8601 qualified as ISO8601 import Data.Vector qualified as Vector import FieldParser (FieldParser) import FieldParser qualified as Field@@ -188,6 +191,64 @@   Json.ParseT err m (Label label (Maybe a)) keyLabelMay' Proxy key parser = label @label <$> Json.keyMay key parser +-- | Parse each value in the array and check that the array is not empty.+eachInArrayNonEmpty ::+  (Monad m) =>+  Json.ParseT Error m a ->+  Json.ParseT Error m (NonEmpty a)+eachInArrayNonEmpty inner =+  Json.eachInArray inner <&> nonEmpty >>= \case+    Nothing -> Json.throwCustomError "Array must not be empty"+    Just a -> pure a++-- | Try to parse a choice, match on the `tag` and use the corresponding parser for `value`+-- If no tag matches, throw a parsing error+--+-- A choice is the conventional encoding of `tag/value`.+choice ::+  (Monad m) =>+  -- | List of `tag`s with their parsers for `value`+  [(Text, Json.ParseT Error m res)] ->+  Json.ParseT Error m res+choice matches = do+  choiceImpl $ \tag ->+    matches+      & findMaybe (\(t, v) -> if t == tag then Just v else Nothing)+      & \case+        Just res -> res+        Nothing -> Json.throwCustomError [fmt|Choice tag was "{tag}" but we only know these tags: {matches <&> fst & show}|]++-- | Try to parse a choice, match on the `tag` and use the corresponding parser for `value`+-- If no tag matches, return the default value.+--+-- A choice is the conventional encoding of `tag/value`.+choiceDef ::+  (Monad m) =>+  -- | Default value if nothing matches.+  res ->+  -- | List of `tag`s with their parsers for `value`+  [(Text, Json.ParseT Error m res)] ->+  Json.ParseT Error m res+choiceDef def matches = do+  choiceImpl $ \tag ->+    matches+      & findMaybe (\(t, v) -> if t == tag then Just v else Nothing)+      & fromMaybe (pure def)++choiceImpl :: (Monad m) => (Text -> Json.ParseT Error m b) -> Json.ParseT Error m b+choiceImpl inner = do+  let keyOrErr k i err =+        Json.keyMay k i >>= \case+          Nothing -> Json.throwCustomError err+          Just a -> pure a+  -- TODO: throw error on extra fields?+  tag <- keyOrErr "tag" Json.asText "Choice needs a tag"+  keyOrErr "value" (inner tag) "Choice needs a value"++-- | Ensure the given structure (e.g. a text) is not empty, or throw the given error.+ensureNotEmpty :: (MonoFoldable mono, Monad m) => err -> mono -> Json.ParseT err m mono+ensureNotEmpty err val = if MonoFoldable.onull val then throwCustomError err else pure val+ -- NOTE: keyRenamed Test in "Json.JsonTest", due to import cycles.  -- | Like 'Json.key', but allows a list of keys that are tried in order.@@ -241,3 +302,18 @@ -- | Create a json array from a list of json values. mkJsonArray :: [Value] -> Value mkJsonArray xs = xs & Vector.fromList & Array++-- | Encode a single possibility into a @tag/value@ object.+mkSingleChoice :: Text -> Value -> Value+mkSingleChoice key val =+  Json.object+    [ ("tag", String key),+      ("value", val)+    ]++-- | Encode UTCTime as 'String', as an ISO8601 timestamp with timezone (@yyyy-mm-ddThh:mm:ss[.sss]Z@)+mkUtcTime :: UTCTime -> Value+mkUtcTime = String . stringToText . ISO8601.iso8601Show @UTCTime++mkMaybe :: (a -> Value) -> Maybe a -> Value+mkMaybe f ma = ma <&> f & toJSON @(Maybe Value)