module Language.JsonGrammar (
liftAeson, option, greedyOption, list, elementBy, array,
propBy, rawFixedProp, rest, ignoreRest, object,
Json(..), fromJson, toJson, litJson, prop, fixedProp, element
) where
import Data.Iso hiding (option)
import Prelude hiding (id, (.), head, maybe, either)
import Control.Category
import Control.Monad
import Data.Aeson hiding (object)
import Data.Aeson.Types (parseMaybe)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.String
import Data.Text (Text)
import qualified Data.Vector as V
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Fusion.Stream as VS
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 :- t) (a :- t) ->
Iso ([Value] :- t) ([Value] :- a :- t)
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 (M.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 (M.notMember textName o)
return (M.insert textName value o)
rest :: Iso (Object :- t) (Object :- M.Map 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 Bool where
grammar = liftAeson
instance Json Int where
grammar = liftAeson
instance Json Integer where
grammar = liftAeson
instance Json Float where
grammar = liftAeson
instance Json Double where
grammar = liftAeson
instance Json [Char] where
grammar = liftAeson
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 Value where
grammar = id
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