module Language.JsonGrammar (
liftAeson, option, greedyOption, list, elementBy, array,
propBy, rawFixedProp, rest, ignoreRest, object,
Json(..), fromJson, toJson, litJson, prop, fixedProp, element
) where
import Prelude hiding (id, (.), head, maybe, either)
import Data.Aeson hiding (object)
import Data.Aeson.Types (parseMaybe)
import Data.Attoparsec.Number
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as Lazy
import Data.Hashable (Hashable)
import Data.Int
import Data.IntSet (IntSet)
import Data.Iso hiding (option)
import qualified Data.HashMap.Lazy as M
import Data.Maybe (fromMaybe, isJust)
import Data.String
import Data.Text (Text)
import qualified Data.Text.Lazy as Lazy
import Data.Time.Clock
import qualified Data.Vector as V
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Fusion.Stream as VS
import Data.Word
import Control.Category
import Control.Monad
aeObject :: Iso (Object :- t) (Value :- t)
aeArray :: Iso (Array :- t) (Value :- t)
aeNull :: Iso t (Value :- t)
(aeObject, aeArray, _, _, _, aeNull) = $(deriveIsos ''Value)
liftAeson :: (FromJSON a, ToJSON a) => Iso (Value :- t) (a :- t)
liftAeson = stack (Iso from to)
where
from = parseMaybe parseJSON
to = Just . toJSON
option :: Iso (Value :- t) (a :- t) -> Iso (Value :- t) (Maybe a :- t)
option g = just . g <> nothing . inverse aeNull
greedyOption :: Iso (Value :- t) (a :- t) -> Iso (Value :- t) (Maybe a :- t)
greedyOption g = nothing . inverse aeNull <> just . g
list :: Iso (Value :- t) (a :- t) -> Iso (Value :- t) ([a] :- t)
list g = duck nil >>> array (many single)
where
single = swap
>>> duck (elementBy g)
>>> swap
>>> duck swap
>>> duck cons
array :: Iso ([Value] :- t1) ([Value] :- t2) -> Iso (Value :- t1) t2
array els = inverse aeArray
>>> vectorReverseList
>>> els
>>> inverse nil
elementBy :: Iso (Value :- t1) t2 -> Iso ([Value] :- t1) ([Value] :- t2)
elementBy g = inverse cons
>>> swap
>>> duck g
vectorReverseList :: Iso (V.Vector a :- t) ([a] :- t)
vectorReverseList = stack (Iso f g)
where
f = Just . VS.toList . VG.streamR
g = Just . VG.unstreamR . VS.fromList
propBy :: Iso (Value :- t) (a :- t) -> String -> Iso (Object :- t) (Object :- a :- t)
propBy g name = duck g . rawProp name
rawProp :: String -> Iso (Object :- t) (Object :- Value :- t)
rawProp name = Iso from to
where
textName = fromString name
from (o :- r) = do
value <- M.lookup textName o
return (M.delete textName o :- value :- r)
to (o :- value :- r) = do
guard (notMember textName o)
return (M.insert textName value o :- r)
rawFixedProp :: String -> Value -> Iso (Object :- t) (Object :- t)
rawFixedProp name value = stack (Iso from to)
where
textName = fromString name
from o = do
value' <- M.lookup textName o
guard (value' == value)
return (M.delete textName o)
to o = do
guard (notMember textName o)
return (M.insert textName value o)
notMember :: (Eq k, Hashable k) => k -> M.HashMap k v -> Bool
notMember k m = isJust (M.lookup k m)
rest :: Iso (Object :- t) (Object :- M.HashMap Text Value :- t)
rest = lit M.empty
ignoreRest :: Iso (Object :- t) (Object :- t)
ignoreRest = lit M.empty . inverse (ignoreWithDefault M.empty)
object :: Iso (Object :- t1) (Object :- t2) -> Iso (Value :- t1) t2
object props = inverse aeObject >>> props >>> inverseLit M.empty
class Json a where
grammar :: Iso (Value :- t) (a :- t)
instance Json a => Json [a] where
grammar = list grammar
instance Json a => Json (Maybe a) where
grammar = option grammar
instance (Json a, Json b) => Json (Either a b) where
grammar = either grammar grammar
instance Json Bool where grammar = liftAeson
instance Json Char where grammar = liftAeson
instance Json Double where grammar = liftAeson
instance Json Float where grammar = liftAeson
instance Json Int where grammar = liftAeson
instance Json Int8 where grammar = liftAeson
instance Json Int16 where grammar = liftAeson
instance Json Int32 where grammar = liftAeson
instance Json Int64 where grammar = liftAeson
instance Json Integer where grammar = liftAeson
instance Json Word where grammar = liftAeson
instance Json Word8 where grammar = liftAeson
instance Json Word16 where grammar = liftAeson
instance Json Word32 where grammar = liftAeson
instance Json Word64 where grammar = liftAeson
instance Json () where grammar = liftAeson
instance Json ByteString where grammar = liftAeson
instance Json Lazy.ByteString where grammar = liftAeson
instance Json Number where grammar = liftAeson
instance Json Text where grammar = liftAeson
instance Json Lazy.Text where grammar = liftAeson
instance Json IntSet where grammar = liftAeson
instance Json UTCTime where grammar = liftAeson
instance Json DotNetTime where grammar = liftAeson
instance Json Value where grammar = id
instance Json [Char] where grammar = liftAeson
unsafeToJson :: Json a => String -> a -> Value
unsafeToJson context value =
fromMaybe err (convert (inverse (unstack grammar)) value)
where
err = error (context ++
": could not convert Haskell value to JSON value")
fromJson :: Json a => Value -> Maybe a
fromJson = convert (unstack grammar)
toJson :: Json a => a -> Maybe Value
toJson = convert (inverse (unstack grammar))
litJson :: Json a => a -> Iso (Value :- t) t
litJson = inverseLit . unsafeToJson "litJson"
prop :: Json a => String -> Iso (Object :- t) (Object :- a :- t)
prop = propBy grammar
fixedProp :: Json a => String -> a -> Iso (Object :- t) (Object :- t)
fixedProp name value = rawFixedProp name (unsafeToJson "fixedProp" value)
element :: Json a => Iso ([Value] :- t) ([Value] :- a :- t)
element = elementBy grammar