packages feed

aeson-better-errors (empty) → 0.1.0.0

raw patch · 6 files changed

+570/−0 lines, 6 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, dlist, mtl, scientific, text, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Harry Garrood++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:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++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.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ aeson-better-errors.cabal view
@@ -0,0 +1,55 @@+name:                aeson-better-errors+version:             0.1.0.0+synopsis:            Better error messages when decoding JSON values.+license:             MIT+license-file:        LICENSE+author:              Harry Garrood+maintainer:          harry@garrood.me+homepage:            https://github.com/hdgarrood/aeson-better-errors+category:            Text, Web, JSON+build-type:          Simple+cabal-version:       >=1.10++description:+  A small package which gives you the tools to build parsers to decode JSON+  values, and gives good error messages when parsing fails.++  See also <http://harry.garrood.me/blog/aeson-better-errors/>.++source-repository head+  type:     git+  location: https://github.com/hdgarrood/aeson-better-errors++library+  exposed-modules:   Data.Aeson.BetterErrors+                     Data.Aeson.BetterErrors.Internal+  other-modules:     Data.Aeson.BetterErrors.Utils+  build-depends:     base >=4 && <5+                   , aeson >=0.6.1.0+                   , unordered-containers+                   , dlist+                   , text+                   , bytestring+                   , scientific+                   , vector+                   , transformers+                   , mtl++  ghc-options:       -Wall+  hs-source-dirs:    src+  default-language:  Haskell2010++-- test-suite tests+--   type:              exitcode-stdio-1.0+--   main-is:           Main.hs+--   hs-source-dirs:    test+--   build-depends:     base >=4 && <5+--                    , aeson -any+--                    , aeson-better-errors -any+--                    , bytestring -any+--                    , text -any+--                    , unordered-containers -any+--                    , tasty -any+--                    , tasty-hunit -any+--   ghc-options:       -Wall -fno-warn-missing-signatures+--   default-language:  Haskell2010
+ src/Data/Aeson/BetterErrors.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++-- | A module for decoding JSON, and generating good better messages. Note,+-- however, that this package only deals with generating good error messages+-- /after/ the JSON has been parsed into a 'Data.Aeson.Value' - unfortunately,+-- invalid JSON will still produce poor error messages.+--+-- See <http://harry.garrood.me/blog/aeson-better-errors/>++module Data.Aeson.BetterErrors+  ( -- * The Parser type+    Parse++  -- * Basic parsers+  , asText+  , asString+  , asScientific+  , asIntegral+  , asRealFloat+  , asBool+  , asNull+  , asObject+  , asArray++  -- * Traversing JSON+  , key+  , keyOrDefault+  , keyMay++  , nth+  , nthOrDefault+  , nthMay++  , eachInArray+  , eachInObject++  -- * Custom validations+  , withText+  , withString+  , withScientific+  , withIntegral+  , withRealFloat+  , withBool+  , withObject+  , withArray++  -- * Running parsers+  , parse+  , parseStrict+  , parseValue++  -- * Errors+  , ParseError(..)+  , PathPiece(..)+  , ErrorSpecifics(..)+  , displayError+  , displayPath+  , displaySpecifics++  -- * Miscellaneous+  , toAesonParser+  , JSONType(..)+  , jsonTypeOf+  ) where++import Data.Aeson (Value) -- for haddock+import Data.Aeson.BetterErrors.Internal++-- TODO Alternative?+-- use monoid, combine errors?+-- Simply take rightmost?+-- Or maybe take the one with the deepest path?+--+-- Or, export our own (<|>) that uses a semigroup (since errors are+-- 'nonempty') - that is, we don't want to allow failing with no error.
+ src/Data/Aeson/BetterErrors/Internal.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Data.Aeson.BetterErrors.Internal where++import Control.Applicative+import Control.Monad.Reader+import Control.Monad.Trans.Except+import Control.Monad.Error.Class (MonadError(..))++import Data.Foldable (foldMap)+import Data.Monoid+import Data.DList (DList)+import qualified Data.DList as DList+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as B++import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import Data.Vector ((!?))+import qualified Data.Vector as V+import Data.Scientific (Scientific)+import qualified Data.Scientific as S+import qualified Data.HashMap.Strict as HashMap++import Data.Aeson.BetterErrors.Utils++-- | The type of parsers: things which consume JSON values and produce either+-- detailed errors or successfully parsed values (of other types).+--+-- The @err@ type parameter is for your own errors; if you don't need to use+-- any errors of your own, simply set it to @()@.+newtype Parse err a+  = Parse (ReaderT ParseReader (Except (ParseError err)) a)+  deriving (Functor, Applicative, Monad,+            MonadReader ParseReader, MonadError (ParseError err))++runParser ::+  (s -> Either String A.Value) ->+  Parse err a ->+  s ->+  Either (ParseError err) a+runParser decode (Parse p) src =+  case decode src of+    Left err -> Left (InvalidJSON err)+    Right value ->+      let initialReader = ParseReader DList.empty value+      in  runExcept (runReaderT p initialReader)++-- | Run a parser with a lazy 'BL.ByteString' containing JSON data. Note that+-- the normal caveat applies: the JSON supplied must contain either an object+-- or an array for this to work.+parse :: Parse err a -> BL.ByteString -> Either (ParseError err) a+parse = runParser A.eitherDecode++-- | Run a parser with a strict 'B.ByteString' containing JSON data. Note that+-- the normal caveat applies: the JSON supplied must contain either an object+-- or an array for this to work.+parseStrict :: Parse err a -> B.ByteString -> Either (ParseError err) a+parseStrict = runParser A.eitherDecodeStrict++-- | Run a parser with a pre-parsed JSON 'A.Value'.+parseValue :: Parse err a -> A.Value -> Either (ParseError err) a+parseValue = runParser Right++-- | This function is useful when you have a @'Parse' err a@ and you want to+-- obtain an instance for @'A.FromJSON' a@. Simply define:+--+-- @+--    parseJSON = toAesonParser showMyCustomError myParser+-- @+toAesonParser :: (err -> Text) -> Parse err a -> A.Value -> A.Parser a+toAesonParser showCustom p val =+  case parseValue p val of+    Right x -> return x+    Left err -> fail (unlines (map T.unpack (displayError showCustom err)))++-- | Data used internally by the 'Parse' type.+data ParseReader = ParseReader+  { rdrPath  :: DList PathPiece+  , rdrValue :: A.Value+  }++appendPath :: PathPiece -> ParseReader -> ParseReader+appendPath p r = r { rdrPath = DList.snoc (rdrPath r) p }++setValue :: A.Value -> ParseReader -> ParseReader+setValue v r = r { rdrValue = v }++-- | A piece of a path leading to a specific part of the JSON data.+-- Internally, a list of these is maintained as the parser traverses the JSON+-- data. This list is included in the error if one occurs.+data PathPiece+  = ObjectKey Text+  | ArrayIndex Int+  deriving (Show, Eq, Ord)++-- | A value indicating that the JSON could not be decoded successfully.+data ParseError err+  = InvalidJSON String+  | BadSchema [PathPiece] (ErrorSpecifics err)+  deriving (Show, Eq)++-- | Detailed information in the case where a value could be parsed as JSON,+-- but a value of the required type could not be constructed from it, for some+-- reason.+data ErrorSpecifics err+  = KeyMissing Text+  | OutOfBounds Int+  | WrongType JSONType A.Value -- ^ Expected type, actual value+  | ExpectedIntegral Double+  | CustomError err+  deriving (Show, Eq)++-- | An enumeration of the different types that JSON values may take.+data JSONType+  = TyObject+  | TyArray+  | TyString+  | TyNumber+  | TyBool+  | TyNull+  deriving (Show, Eq, Ord)++displayJSONType :: JSONType -> Text+displayJSONType t = case t of+  TyObject -> "object"+  TyArray  -> "array"+  TyString -> "string"+  TyNumber -> "number"+  TyBool   -> "boolean"+  TyNull   -> "null"++-- | Turn a 'ParseError' into a human-readable list of 'Text' values.+-- They will be in a sensible order. For example, you can feed the result to+-- @mapM putStrLn@, or @unlines@.+displayError :: (err -> Text) -> ParseError err -> [Text]+displayError _ (InvalidJSON str) =+  [ "The input could not be parsed as JSON", "aeson said: " <> T.pack str ]+displayError f (BadSchema [] specs) =+  displaySpecifics f specs+displayError f (BadSchema path specs) =+  [ "At the path: " <> displayPath path ] <> displaySpecifics f specs++displayPath :: [PathPiece] -> Text+displayPath = foldMap showPiece+  where+  showPiece (ObjectKey t)  = "[" <> tshow t <> "]"+  showPiece (ArrayIndex i) = "[" <> tshow i <> "]"++displaySpecifics :: (err -> Text) -> ErrorSpecifics err -> [Text]+displaySpecifics _ (KeyMissing k) =+  [ "The required key " <> tshow k <> " is missing" ]+displaySpecifics _ (OutOfBounds i) =+  [ "The array index " <> tshow i <> " is out of bounds" ]+displaySpecifics _ (WrongType t val) =+  [ "Type mismatch:"+  , "Expected a value of type " <> displayJSONType t+  , "Got: " <> decodeUtf8 (BL.toStrict (A.encode val))+  ]+displaySpecifics _ (ExpectedIntegral x) =+  [ "Expected an integral value, got " <> tshow x ]+displaySpecifics f (CustomError err) =+  [ f err ]++-- | Get the type of a JSON value.+jsonTypeOf :: A.Value -> JSONType+jsonTypeOf (A.Object _) = TyObject+jsonTypeOf (A.Array _)  = TyArray+jsonTypeOf (A.String _) = TyString+jsonTypeOf (A.Number _) = TyNumber+jsonTypeOf (A.Bool _)   = TyBool+jsonTypeOf A.Null       = TyNull++-- | Lift any parsing function into the 'Parse' type.+liftParse :: (A.Value -> Either (ErrorSpecifics err) a) -> Parse err a+liftParse f =+  asks rdrValue+    >>= either badSchema return . f++-- | Aborts parsing, due to an error in the structure of the JSON - that is,+-- any error other than the JSON not actually being parseable into a 'A.Value'.+badSchema :: ErrorSpecifics err -> Parse err a+badSchema specifics = do+  path <- asks rdrPath+  throwError (BadSchema (DList.toList path) specifics)++as :: (A.Value -> Maybe a) -> JSONType -> Parse err a+as pat ty = liftParse $ \v ->+  maybe (Left (WrongType ty v)) Right (pat v)++-- | Parse a single JSON string as 'Text'.+asText :: Parse err Text+asText = as patString TyString++-- | Parse a single JSON string as a 'String'.+asString :: Parse err String+asString = T.unpack <$> asText++-- | Parse a single JSON number as a 'Scientific'.+asScientific :: Parse err Scientific+asScientific = as patNumber TyNumber++-- | Parse a single JSON number as any 'Integral' type.+asIntegral :: Integral a => Parse err a+asIntegral =+  S.floatingOrInteger <$> asScientific+    >>= either (badSchema . ExpectedIntegral) return++-- | Parse a single JSON number as any 'RealFloat' type.+asRealFloat :: RealFloat a => Parse err a+asRealFloat =+  floatingOrInteger <$> asScientific+    >>= either return (return . fromIntegral)+  where+  -- This local declaration is just here to give GHC a hint as to which type+  -- should be used in the case of an Integral (here, we choose Integer, for+  -- safety).+  floatingOrInteger :: RealFloat b => Scientific -> Either b Integer+  floatingOrInteger = S.floatingOrInteger++-- | Parse a single JSON boolean as a 'Bool'.+asBool :: Parse err Bool+asBool = as patBool TyBool++-- | Parse a JSON object, as an 'A.Object'. You should prefer functions like+-- 'eachInObject' where possible, since they will usually generate better+-- error messages.+asObject :: Parse err A.Object+asObject = as patObject TyObject++-- | Parse a JSON array, as an 'A.Array'. You should prefer functions like+-- 'eachInArray' where possible, since they will usually generate better+-- error messages.+asArray :: Parse err A.Array+asArray = as patArray TyArray++-- | Parse a single JSON null value. Useful if you want to throw an error in+-- the case where something is not null.+asNull :: Parse err ()+asNull = as patNull TyNull++-- | Take the value corresponding to a given key in the current object.+key :: Text -> Parse err a -> Parse err a+key k p = key' (badSchema (KeyMissing k)) k p++-- | Take the value corresponding to a given key in the current object, or+-- if no property exists with that key, use the supplied default.+keyOrDefault :: Text -> a -> Parse err a -> Parse err a+keyOrDefault k def p = key' (pure def) k p++-- | Take the value corresponding to a given key in the current object, or+-- if no property exists with that key, return Nothing .+keyMay :: Text -> Parse err a -> Parse err (Maybe a)+keyMay k p = keyOrDefault k Nothing (Just <$> p)++key' :: Parse err a -> Text -> Parse err a -> Parse err a+key' onMissing k p = do+  v <- asks rdrValue+  case v of+    A.Object obj ->+      case HashMap.lookup k obj of+        Just v' ->+          local (appendPath (ObjectKey k) . setValue v') p+        Nothing ->+          onMissing+    _ ->+      badSchema (WrongType TyObject v)++-- | Take the nth value of the current array.+nth :: Int -> Parse err a -> Parse err a+nth n p = nth' (badSchema (OutOfBounds n)) n p++-- | Take the nth value of the current array, or if no value exists with that+-- index, use the supplied default.+nthOrDefault :: Int -> a -> Parse err a -> Parse err a+nthOrDefault n def p =+  nth' (pure def) n p++-- | Take the nth value of the current array, or if no value exists with that+-- index, return Nothing.+nthMay :: Int -> Parse err a -> Parse err (Maybe a)+nthMay n p = nthOrDefault n Nothing (Just <$> p)++nth' :: Parse err a -> Int -> Parse err a -> Parse err a+nth' onMissing n p = do+  v <- asks rdrValue+  case v of+    A.Array vect ->+      case vect !? n of+        Just v' ->+          local (appendPath (ArrayIndex n) . setValue v') p+        Nothing ->+          onMissing+    _ ->+      badSchema (WrongType TyArray v)++-- | Attempt to parse each value in the array with the given parser, and+-- collect the results.+eachInArray :: Parse err a -> Parse err [a]+eachInArray p = do+  xs <- zip [0..] . V.toList <$> asArray+  forM xs $ \(i, x) ->+    local (appendPath (ArrayIndex i) . setValue x) p++-- | Attempt to parse each property value in the array with the given parser,+-- and collect the results.+eachInObject :: Parse err a -> Parse err [(Text, a)]+eachInObject p = do+  xs <- HashMap.toList <$> asObject+  forM xs $ \(k, x) ->+    (k,) <$> local (appendPath (ObjectKey k) . setValue x) p++-- | Lifts a function attempting to validate an arbitrary JSON value into a+-- parser. You should only use this if absolutely necessary; the other+-- functions in this module will generally give better error reporting.+withValue :: (A.Value -> Either err a) -> Parse err a+withValue f = liftParse (mapLeft CustomError . f)++liftEither :: Either err a -> Parse err a+liftEither = either (badSchema . CustomError) return++with :: Parse err a -> (a -> Either err b) -> Parse err b+with g f = g >>= liftEither . f++withText :: (Text -> Either err a) -> Parse err a+withText = with asText++withString :: (String -> Either err a) -> Parse err a+withString = with asString++withScientific :: (Scientific -> Either err a) -> Parse err a+withScientific = with asScientific++withIntegral :: Integral a => (a -> Either err b) -> Parse err b+withIntegral = with asIntegral++withRealFloat :: RealFloat a => (a -> Either err b) -> Parse err b+withRealFloat = with asRealFloat++withBool :: (Bool -> Either err a) -> Parse err a+withBool = with asBool++-- | Prefer to use functions like 'key or 'eachInObject' to this one where+-- possible, as they will generate better error messages.+withObject :: (A.Object -> Either err a) -> Parse err a+withObject = with asObject++-- | Prefer to use functions like 'nth' or 'eachInArray' to this one where+-- possible, as they will generate better error messages.+withArray :: (A.Array -> Either err a) -> Parse err a+withArray = with asArray
+ src/Data/Aeson/BetterErrors/Utils.hs view
@@ -0,0 +1,58 @@++module Data.Aeson.BetterErrors.Utils where++import Control.Monad.Error.Class (MonadError(..))++import qualified Data.Aeson as A+import Data.Scientific (Scientific)+import Data.Text (Text, pack)++-----------------------+-- Various utilities++tshow :: Show a => a -> Text+tshow = pack . show++-- | A version of catchJust from "Control.Exception.Base", except for any+-- instance of 'MonadError'.+catchJust :: MonadError e m+  => (e -> Maybe b) -- ^ Predicate to select exceptions+  -> m a            -- ^ Computation to run+  -> (b -> m a)     -- ^ Handler+  -> m a+catchJust p act handler = catchError act handle+  where+  handle e =+    case p e of+      Nothing -> throwError e+      Just b -> handler b++mapLeft :: (a -> b) -> Either a c -> Either b c+mapLeft f (Left x) = Left (f x)+mapLeft _ (Right y) = Right y++-- Value-level patterns for json values++patNull :: A.Value -> Maybe ()+patNull A.Null = Just ()+patNull _ = Nothing++patString :: A.Value -> Maybe Text+patString (A.String t) = Just t+patString _ = Nothing++patNumber :: A.Value -> Maybe Scientific+patNumber (A.Number x) = Just x+patNumber _ = Nothing++patBool :: A.Value -> Maybe Bool+patBool (A.Bool x) = Just x+patBool _ = Nothing++patObject :: A.Value -> Maybe A.Object+patObject (A.Object obj) = Just obj+patObject _ = Nothing++patArray :: A.Value -> Maybe A.Array+patArray (A.Array arr) = Just arr+patArray _ = Nothing