module Data.Aeson.Quick
(
module Ae
, (.?)
, (.!)
, extract
, (.%)
, build
, Structure(..)
, parseStructure
) where
import Control.Applicative
import Control.Monad
import Control.DeepSeq
import Data.Aeson as Ae
import qualified Data.Aeson.Types as AT
import Data.Attoparsec.Text hiding (parse)
import Data.Char
import qualified Data.HashMap.Strict as H
import Data.Monoid
import Data.String
import qualified Data.Text as T
import qualified Data.Vector as V
import GHC.Generics (Generic)
data Structure = Obj [(T.Text, Bool, Structure)]
| Arr Structure
| Val
deriving (Eq, Ord, Generic)
instance NFData Structure
instance IsString Structure where
fromString s =
let e = error $ "Invalid structure: " ++ s
in either (\_ -> e) id $ parseStructure $ T.pack s
instance Show Structure where
show (Val) = "Val"
show (Arr s) = "[" ++ show s ++ "]"
show (Obj xs) = "{" ++ drop 1 (concatMap go xs) ++ "}"
where go (k,o,s) = "," ++ T.unpack k ++ (if o then "?" else "")
++ (if s == Val then "" else ":" ++ show s)
parseStructure :: T.Text -> Either String Structure
parseStructure = parseOnly structure
where
structure = object' <|> array
object' = Obj <$> ("{" *> sepBy1 lookups (char ',') <* "}")
array = Arr <$> ("[" *> structure <* "]")
lookups = (,,) <$> (takeWhile1 isKeyChar)
<*> ("?" *> pure True <|> pure False)
<*> (":" *> structure <|> pure Val)
isKeyChar = isAlphaNum
(.?) :: FromJSON a => Value -> Structure -> Maybe a
(.?) = AT.parseMaybe . flip extract
(.!) :: FromJSON a => Value -> Structure -> a
(.!) v s = either err id $ AT.parseEither (extract s) v
where err msg = error $ show s ++ ": " ++ msg ++ " in " ++ show v
extract :: FromJSON a => Structure -> Value -> AT.Parser a
extract structure = go structure >=> parseJSON
where
go (Obj [s]) = withObject "" (flip look s)
go (Obj sx) = withObject "" (forM sx . look) >=> pure . toJSON
go (Arr s) = withArray "" (V.mapM $ go s) >=> pure . Array
go Val = pure
look v (k,False,Val) = v .: k
look v (k,False,s) = v .: k >>= go s
look v (k,True,s) = v .:? k >>= maybe (pure Null) (go s)
(.%) :: ToJSON a => Structure -> a -> Value
(.%) s = build s Null
build :: ToJSON a => Structure -> Value -> a -> Value
build structure val = go structure val . toJSON
where
go (Val) _ r = r
go (Arr s) (Array v) (Array r) = Array $ V.zipWith (go s) v r
go (Arr s) Null (Array r) = Array $ V.map (go s Null) r
go (Arr s) Null r = toJSON [go s Null r]
go (Obj [ks]) (Object v) r = Object $ update v ks r
go (Obj keys) Null r = go (Obj keys) (Object mempty) r
go (Obj ks) (Object v) (Array r) = Object $
let maps = zip ks (V.toList r)
in foldl (\v' (s,r') -> update v' s r') v maps
go (Obj keys) (Object v) r = r
go a b c = error $ show (a,b,c)
update v (k,_,s) r =
let startVal = go s (H.lookupDefault Null k v) r
in H.insert k startVal v