1{-# LANGUAGE GeneralizedNewtypeDeriving #-} 2{-# LANGUAGE ViewPatterns #-} 3{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE CPP #-} 5module Data.Aeson.Config.Parser ( 6 Parser 7, runParser 8 9, typeMismatch 10, withObject 11, withText 12, withString 13, withArray 14, withNumber 15, withBool 16 17, explicitParseField 18, explicitParseFieldMaybe 19 20, Aeson.JSONPathElement(..) 21, (<?>) 22 23, Value(..) 24, Object 25, Array 26 27, liftParser 28 29, fromAesonPath 30, formatPath 31) where 32 33import Control.Monad 34import Control.Applicative 35import qualified Control.Monad.Fail as Fail 36import Control.Monad.Trans.Class 37import Control.Monad.Trans.Writer 38import Data.Monoid ((<>)) 39import Data.Scientific 40import Data.Set (Set, notMember) 41import qualified Data.Set as Set 42import Data.Text (Text) 43import qualified Data.Text as T 44import qualified Data.Vector as V 45import qualified Data.HashMap.Strict as HashMap 46import Data.Aeson.Types (Value(..), Object, Array) 47import qualified Data.Aeson.Types as Aeson 48import Data.Aeson.Internal (IResult(..), iparse) 49#if !MIN_VERSION_aeson(1,4,5) 50import qualified Data.Aeson.Internal as Aeson 51#endif 52 53-- This is needed so that we have an Ord instance for aeson < 1.2.4. 54data JSONPathElement = Key Text | Index Int 55 deriving (Eq, Show, Ord) 56 57type JSONPath = [JSONPathElement] 58 59fromAesonPath :: Aeson.JSONPath -> JSONPath 60fromAesonPath = reverse . map fromAesonPathElement 61 62fromAesonPathElement :: Aeson.JSONPathElement -> JSONPathElement 63fromAesonPathElement e = case e of 64 Aeson.Key k -> Key k 65 Aeson.Index n -> Index n 66 67newtype Parser a = Parser {unParser :: WriterT (Set JSONPath) Aeson.Parser a} 68 deriving (Functor, Applicative, Alternative, Monad, Fail.MonadFail) 69 70liftParser :: Aeson.Parser a -> Parser a 71liftParser = Parser . lift 72 73runParser :: (Value -> Parser a) -> Value -> Either String (a, [String]) 74runParser p v = case iparse (runWriterT . unParser <$> p) v of 75 IError path err -> Left ("Error while parsing " ++ formatPath (fromAesonPath path) ++ " - " ++ err) 76 ISuccess (a, consumed) -> Right (a, map formatPath (determineUnconsumed consumed v)) 77 78formatPath :: JSONPath -> String 79formatPath = go "$" . reverse 80 where 81 go :: String -> JSONPath -> String 82 go acc path = case path of 83 [] -> acc 84 Index n : xs -> go (acc ++ "[" ++ show n ++ "]") xs 85 Key key : xs -> go (acc ++ "." ++ T.unpack key) xs 86 87determineUnconsumed :: Set JSONPath -> Value -> [JSONPath] 88determineUnconsumed ((<> Set.singleton []) -> consumed) = Set.toList . execWriter . go [] 89 where 90 go :: JSONPath -> Value -> Writer (Set JSONPath) () 91 go path value 92 | path `notMember` consumed = tell (Set.singleton path) 93 | otherwise = case value of 94 Number _ -> return () 95 String _ -> return () 96 Bool _ -> return () 97 Null -> return () 98 Object o -> do 99 forM_ (HashMap.toList o) $ \ (k, v) -> do 100 unless ("_" `T.isPrefixOf` k) $ do 101 go (Key k : path) v 102 Array xs -> do 103 forM_ (zip [0..] $ V.toList xs) $ \ (n, v) -> do 104 go (Index n : path) v 105 106(<?>) :: Parser a -> Aeson.JSONPathElement -> Parser a 107(<?>) (Parser (WriterT p)) e = do 108 Parser (WriterT (p Aeson.<?> e)) <* markConsumed (fromAesonPathElement e) 109 110markConsumed :: JSONPathElement -> Parser () 111markConsumed e = do 112 path <- getPath 113 Parser $ tell (Set.singleton $ e : path) 114 115getPath :: Parser JSONPath 116getPath = liftParser $ Aeson.parserCatchError empty $ \ path _ -> return (fromAesonPath path) 117 118explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a 119explicitParseField p o key = case HashMap.lookup key o of 120 Nothing -> fail $ "key " ++ show key ++ " not present" 121 Just v -> p v <?> Aeson.Key key 122 123explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a) 124explicitParseFieldMaybe p o key = case HashMap.lookup key o of 125 Nothing -> pure Nothing 126 Just v -> Just <$> p v <?> Aeson.Key key 127 128typeMismatch :: String -> Value -> Parser a 129typeMismatch expected = liftParser . Aeson.typeMismatch expected 130 131withObject :: (Object -> Parser a) -> Value -> Parser a 132withObject p (Object o) = p o 133withObject _ v = typeMismatch "Object" v 134 135withText :: (Text -> Parser a) -> Value -> Parser a 136withText p (String s) = p s 137withText _ v = typeMismatch "String" v 138 139withString :: (String -> Parser a) -> Value -> Parser a 140withString p = withText (p . T.unpack) 141 142withArray :: (Array -> Parser a) -> Value -> Parser a 143withArray p (Array xs) = p xs 144withArray _ v = typeMismatch "Array" v 145 146withNumber :: (Scientific -> Parser a) -> Value -> Parser a 147withNumber p (Number n) = p n 148withNumber _ v = typeMismatch "Number" v 149 150withBool :: (Bool -> Parser a) -> Value -> Parser a 151withBool p (Bool b) = p b 152withBool _ v = typeMismatch "Boolean" v 153