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