{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Aeson.Config.Parser (
Parser
, runParser
, typeMismatch
, withObject
, withText
, withString
, withArray
, withNumber
, withBool
, explicitParseField
, explicitParseFieldMaybe
, Aeson.JSONPathElement(..)
, (<?>)
, Value(..)
, Object
, Array
, liftParser
, fromAesonPath
, formatPath
) where
import Control.Monad
import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer
import Data.Monoid ((<>))
import Data.Scientific
import Data.Set (Set, notMember)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as HashMap
import Data.Aeson.Types (Value(..), Object, Array)
import qualified Data.Aeson.Types as Aeson
import Data.Aeson.Internal (IResult(..), iparse)
import qualified Data.Aeson.Internal as Aeson
data JSONPathElement = Key Text | Index Int
deriving (Eq, Show, Ord)
type JSONPath = [JSONPathElement]
fromAesonPath :: Aeson.JSONPath -> JSONPath
fromAesonPath = reverse . map fromAesonPathElement
fromAesonPathElement :: Aeson.JSONPathElement -> JSONPathElement
fromAesonPathElement e = case e of
Aeson.Key k -> Key k
Aeson.Index n -> Index n
newtype Parser a = Parser {unParser :: WriterT (Set JSONPath) Aeson.Parser a}
deriving (Functor, Applicative, Alternative, Monad)
liftParser :: Aeson.Parser a -> Parser a
liftParser = Parser . lift
runParser :: (Value -> Parser a) -> Value -> Either String (a, [String])
runParser p v = case iparse (runWriterT . unParser <$> p) v of
IError path err -> Left ("Error while parsing " ++ formatPath (fromAesonPath path) ++ " - " ++ err)
ISuccess (a, consumed) -> Right (a, map formatPath (determineUnconsumed consumed v))
formatPath :: JSONPath -> String
formatPath = go "$" . reverse
where
go :: String -> JSONPath -> String
go acc path = case path of
[] -> acc
Index n : xs -> go (acc ++ "[" ++ show n ++ "]") xs
Key key : xs -> go (acc ++ "." ++ T.unpack key) xs
determineUnconsumed :: Set JSONPath -> Value -> [JSONPath]
determineUnconsumed ((<> Set.singleton []) -> consumed) = Set.toList . execWriter . go []
where
go :: JSONPath -> Value -> Writer (Set JSONPath) ()
go path value
| path `notMember` consumed = tell (Set.singleton path)
| otherwise = case value of
Number _ -> return ()
String _ -> return ()
Bool _ -> return ()
Null -> return ()
Object o -> do
forM_ (HashMap.toList o) $ \ (k, v) -> do
unless ("_" `T.isPrefixOf` k) $ do
go (Key k : path) v
Array xs -> do
forM_ (zip [0..] $ V.toList xs) $ \ (n, v) -> do
go (Index n : path) v
(<?>) :: Parser a -> Aeson.JSONPathElement -> Parser a
(<?>) (Parser (WriterT p)) e = do
Parser (WriterT (p Aeson.<?> e)) <* markConsumed (fromAesonPathElement e)
markConsumed :: JSONPathElement -> Parser ()
markConsumed e = do
path <- getPath
Parser $ tell (Set.singleton $ e : path)
getPath :: Parser JSONPath
getPath = liftParser $ Aeson.parserCatchError empty $ \ path _ -> return (fromAesonPath path)
explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
explicitParseField p o key = case HashMap.lookup key o of
Nothing -> fail $ "key " ++ show key ++ " not present"
Just v -> p v <?> Aeson.Key key
explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)
explicitParseFieldMaybe p o key = case HashMap.lookup key o of
Nothing -> pure Nothing
Just v -> Just <$> p v <?> Aeson.Key key
typeMismatch :: String -> Value -> Parser a
typeMismatch expected = liftParser . Aeson.typeMismatch expected
withObject :: (Object -> Parser a) -> Value -> Parser a
withObject p (Object o) = p o
withObject _ v = typeMismatch "Object" v
withText :: (Text -> Parser a) -> Value -> Parser a
withText p (String s) = p s
withText _ v = typeMismatch "String" v
withString :: (String -> Parser a) -> Value -> Parser a
withString p = withText (p . T.unpack)
withArray :: (Array -> Parser a) -> Value -> Parser a
withArray p (Array xs) = p xs
withArray _ v = typeMismatch "Array" v
withNumber :: (Scientific -> Parser a) -> Value -> Parser a
withNumber p (Number n) = p n
withNumber _ v = typeMismatch "Number" v
withBool :: (Bool -> Parser a) -> Value -> Parser a
withBool p (Bool b) = p b
withBool _ v = typeMismatch "Boolean" v