    {-# 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

    -- This is needed so that we have an Ord instance for aeson < 1.2.4.
    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