diff options
Diffstat (limited to 'users/Profpatsch/my-prelude')
| -rw-r--r-- | users/Profpatsch/my-prelude/Aeson.hs | 188 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Data/Error/Tree.hs | 113 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/default.nix | 8 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/my-prelude.cabal | 7 |
4 files changed, 315 insertions, 1 deletions
diff --git a/users/Profpatsch/my-prelude/Aeson.hs b/users/Profpatsch/my-prelude/Aeson.hs new file mode 100644 index 000000000000..ad095e1b43a7 --- /dev/null +++ b/users/Profpatsch/my-prelude/Aeson.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Aeson where + +import Data.Aeson (Encoding, FromJSON (parseJSON), GFromJSON, GToEncoding, GToJSON, Options (fieldLabelModifier), ToJSON (toEncoding, toJSON), Value (..), Zero, defaultOptions, genericParseJSON, genericToEncoding, genericToJSON, withObject) +import Data.Aeson.BetterErrors qualified as Json +import Data.Aeson.Encoding qualified as Enc +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Char qualified +import Data.Error.Tree +import Data.Foldable qualified as Foldable +import Data.Int (Int64) +import Data.List (isPrefixOf) +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.String (IsString (fromString)) +import Data.Text.Lazy qualified as Lazy +import Data.Vector qualified as Vector +import GHC.Generics (Generic (Rep)) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Label +import MyPrelude +import Test.Hspec (describe, it, shouldBe) +import Test.Hspec qualified as Hspec + +-- | Convert a 'Json.ParseError' to a corresponding 'ErrorTree' +parseErrorTree :: Error -> Json.ParseError Error -> ErrorTree +parseErrorTree contextMsg errs = + errs + & Json.displayError prettyError + <&> newError + & nonEmpty + & \case + Nothing -> singleError contextMsg + Just errs' -> errorTree contextMsg errs' + +-- | 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 + +-- | 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 + +test_keyRenamed :: Hspec.Spec +test_keyRenamed = do + describe "keyRenamed" $ do + let parser = keyRenamed ("new" :| ["old"]) Json.asText + let p = Json.parseValue @() parser + it "accepts the new key and the old key" $ do + p (Object (KeyMap.singleton "new" (String "text"))) + `shouldBe` (Right "text") + p (Object (KeyMap.singleton "old" (String "text"))) + `shouldBe` (Right "text") + it "fails with the old key in the error if the inner parser is wrong" $ do + p (Object (KeyMap.singleton "old" Null)) + `shouldBe` (Left (Json.BadSchema [Json.ObjectKey "old"] (Json.WrongType Json.TyString Null))) + it "fails with the new key in the error if the inner parser is wrong" $ do + p (Object (KeyMap.singleton "new" Null)) + `shouldBe` (Left (Json.BadSchema [Json.ObjectKey "new"] (Json.WrongType Json.TyString Null))) + it "fails if the key is missing" $ do + p (Object KeyMap.empty) + `shouldBe` (Left (Json.BadSchema [] (Json.KeyMissing "new"))) + describe "keyRenamedMay" $ do + let parser = keyRenamedMay ("new" :| ["old"]) Json.asText + let p = Json.parseValue @() parser + it "accepts the new key and the old key" $ do + p (Object (KeyMap.singleton "new" (String "text"))) + `shouldBe` (Right (Just "text")) + p (Object (KeyMap.singleton "old" (String "text"))) + `shouldBe` (Right (Just "text")) + it "allows the old and new key to be missing" $ do + p (Object KeyMap.empty) + `shouldBe` (Right Nothing) + +-- | Create a json array from a list of json values. +jsonArray :: [Value] -> Value +jsonArray xs = xs & Vector.fromList & Array diff --git a/users/Profpatsch/my-prelude/Data/Error/Tree.hs b/users/Profpatsch/my-prelude/Data/Error/Tree.hs new file mode 100644 index 000000000000..e8e45e704882 --- /dev/null +++ b/users/Profpatsch/my-prelude/Data/Error/Tree.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Data.Error.Tree where + +import Data.String (IsString (..)) +import Data.Tree qualified as Tree +import MyPrelude + +-- | A tree of 'Error's, with a single root 'Error' and 0..n nested 'ErrorTree's. +-- +-- @@ +-- top error +-- | +-- |-- error 1 +-- | | +-- | -- error 1.1 +-- | +-- |-- error 2 +-- @@ +newtype ErrorTree = ErrorTree {unErrorTree :: (Tree.Tree Error)} + deriving stock (Show) + +instance IsString ErrorTree where + fromString = singleError . fromString + +-- deriving newtype (Ord) -- TODO: Add this instance with containers-0.6.5 + +-- | Turn a single 'Error' into an 'ErrorTree', a leaf. +singleError :: Error -> ErrorTree +singleError e = ErrorTree $ Tree.Node e [] + +-- | Take a list of errors & create a new 'ErrorTree' with the given 'Error' as the root. +errorTree :: Error -> NonEmpty Error -> ErrorTree +errorTree topLevelErr nestedErrs = + ErrorTree + ( Tree.Node + topLevelErr + (nestedErrs <&> (\e -> Tree.Node e []) & toList) + ) + +-- | Attach more context to the root 'Error' of the 'ErrorTree', via 'errorContext'. +errorTreeContext :: Text -> ErrorTree -> ErrorTree +errorTreeContext context (ErrorTree tree) = + ErrorTree $ + tree + { Tree.rootLabel = tree.rootLabel & errorContext context + } + +-- | Nest the given 'Error' around the ErrorTree +-- +-- @@ +-- top level error +-- | +-- -- nestedError +-- | +-- -- error 1 +-- | +-- -- error 2 +-- @@ +nestedError :: + Error -> -- top level + ErrorTree -> -- nested + ErrorTree +nestedError topLevelErr nestedErr = + ErrorTree $ + Tree.Node + { Tree.rootLabel = topLevelErr, + Tree.subForest = [nestedErr.unErrorTree] + } + +-- | Nest the given 'Error' around the list of 'ErrorTree's. +-- +-- @@ +-- top level error +-- | +-- |- nestedError1 +-- | | +-- | -- error 1 +-- | | +-- | -- error 2 +-- | +-- |- nestedError 2 +-- @@ +nestedMultiError :: + Error -> -- top level + NonEmpty ErrorTree -> -- nested + ErrorTree +nestedMultiError topLevelErr nestedErrs = + ErrorTree $ + Tree.Node + { Tree.rootLabel = topLevelErr, + Tree.subForest = nestedErrs & toList <&> (.unErrorTree) + } + +prettyErrorTree :: ErrorTree -> Text +prettyErrorTree (ErrorTree tree) = + tree + <&> prettyError + <&> textToString + & Tree.drawTree + & stringToText + +prettyErrorTrees :: NonEmpty ErrorTree -> Text +prettyErrorTrees forest = + forest + <&> (.unErrorTree) + <&> fmap prettyError + <&> fmap textToString + & toList + & Tree.drawForest + & stringToText diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 87731394fc47..8ff36a93d4e4 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/users/Profpatsch/my-prelude/default.nix @@ -9,11 +9,15 @@ pkgs.haskellPackages.mkDerivation { ./MyPrelude.hs ./Label.hs ./Pretty.hs + ./Data/Error/Tree.hs + ./Aeson.hs ]; isLibrary = true; libraryHaskellDepends = [ + pkgs.haskellPackages.aeson + pkgs.haskellPackages.aeson-better-errors pkgs.haskellPackages.PyF pkgs.haskellPackages.errors pkgs.haskellPackages.profunctors @@ -21,10 +25,12 @@ pkgs.haskellPackages.mkDerivation { pkgs.haskellPackages.these pkgs.haskellPackages.validation-selective pkgs.haskellPackages.error - + pkgs.haskellPackages.hspec + pkgs.haskellPackages.hspec-expectations-pretty-diff pkgs.haskellPackages.hscolour pkgs.haskellPackages.nicify-lib pkgs.haskellPackages.ansi-terminal + pkgs.haskellPackages.vector ]; license = lib.licenses.mit; diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index 48e71bb926a3..8ee3271d10fa 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -9,6 +9,8 @@ library MyPrelude Label Pretty + Data.Error.Tree + Aeson -- Modules included in this executable, other than Main. -- other-modules: @@ -17,6 +19,8 @@ library -- other-extensions: build-depends: base >=4.15 && <5 + , aeson + , aeson-better-errors , PyF , validation-selective , these @@ -27,7 +31,10 @@ library , error , bytestring , mtl + , hspec + , hspec-expectations-pretty-diff , hscolour , nicify-lib , ansi-terminal + , vector default-language: Haskell2010 |