{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
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) = "," ++ showKey (T.unpack k) ++ (if o then "?" else "")
++ (if s == Val then "" else ":" ++ show s)
showKey "" = ""
showKey (':':xs) = "\\:" ++ showKey xs
showKey (',':xs) = "\\," ++ showKey xs
showKey (c:xs) = c : showKey xs
parseStructure :: T.Text -> Either String Structure
parseStructure = parseOnly structure
where
structure :: Parser Structure
structure = object' <|> array <|> val
object' :: Parser Structure
object' = Obj <$> ("{" *> sepBy1 lookups (char ',') <* "}")
array :: Parser Structure
array = Arr <$> ("[" *> structure <* "]")
val :: Parser Structure
val = "." >> pure Val
lookups :: Parser (T.Text, Bool, Structure)
lookups = (,,) <$> (quotedKey <|> plainKey)
<*> ("?" *> pure True <|> pure False)
<*> (":" *> structure <|> pure Val)
quotedKey :: Parser T.Text
quotedKey = "\"" *> scan False testChar <* "\""
testChar :: Bool -> Char -> Maybe Bool
testChar False '"' = Nothing
testChar False '\\' = Just True
testChar _ _ = Just False
plainKey :: Parser T.Text
plainKey = takeWhile1 (notInClass "\",:{}?")
(.?) :: FromJSON a => Value -> Structure -> Maybe a
(.?) = AT.parseMaybe . flip extract
{-# INLINE (.?) #-}
(.!) :: 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
{-# INLINE (.!) #-}
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
{-# INLINE (.%) #-}
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