module Language.JsonGrammar (
liftAeson, option, greedyOption, array,
propBy, rawFixedProp, rest, ignoreRest, object,
Json(..), fromJson, toJson, litJson, prop, fixedProp
) 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
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
array :: Iso (Value :- t) (a :- t) -> Iso (Value :- t) ([a] :- t)
array g = inverse aeArray >>> vectorList >>> elements
where
elements = (inverse cons >>> swap >>> duck g >>> swap >>>
duck elements >>> cons)
<> (inverse nil >>> nil)
vectorList :: Iso (V.Vector a :- t) ([a] :- t)
vectorList = stack (Iso f g)
where
f = Just . V.toList
g = Just . V.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 = array 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)