module Data.HighJson.Types
( HighSpec(..), SpecType(..)
, BodySpec(..)
, RecordFields(..), RecordField(..), RecordSpec(..)
, SumOptions(..), SumOption(..), SumSpec(..)
, EnumOption(..), EnumSpec(..)
, jsonSerializer, jsonEncoder, jsonParser
)
where
import Control.Applicative
import Control.Lens hiding ((.=))
import Control.Monad
import Data.Aeson
import Data.Aeson.Types hiding (parse)
import Data.HVect
import Data.Monoid
import qualified Data.Text as T
data SpecType
= SpecRecord
| SpecSum
| SpecEnum
data HighSpec a (ty :: SpecType) as
= HighSpec
{ hs_name :: !T.Text
, hs_description :: !(Maybe T.Text)
, hs_bodySpec :: !(BodySpec ty a as)
}
data BodySpec ty a as where
BodySpecRecord :: !(RecordSpec a as) -> BodySpec 'SpecRecord a as
BodySpecSum :: !(SumSpec a as) -> BodySpec 'SpecSum a as
BodySpecEnum :: !(EnumSpec a) -> BodySpec 'SpecEnum a as
data RecordFields t fs where
RFEmpty :: RecordFields t '[]
(:+:) :: RecordField t f -> RecordFields t fs -> RecordFields t (f ': fs)
infixr 5 :+:
data RecordField t f
= RecordField
{ rf_jsonKey :: !T.Text
, rf_optional :: !Bool
, rf_jsonLoader :: Object -> T.Text -> Parser f
, rf_get :: !(t -> f)
}
data RecordSpec a fs
= RecordSpec
{ rs_make :: HVect fs -> a
, rs_fields :: RecordFields a fs
}
data SumOptions t os where
SOEmpty :: SumOptions t '[]
(:|:) :: SumOption t o -> SumOptions t os -> SumOptions t (o ': os)
infixr 5 :|:
data SumOption t o
= SumOption
{ so_jsonKey :: !T.Text
, so_prism :: !(Prism' t o)
}
data SumSpec a os
= SumSpec
{ ss_options :: SumOptions a os
}
data EnumOption t
= EnumOption
{ eo_jsonKey :: !T.Text
, eo_prism :: !(Prism' t ())
}
data EnumSpec a
= EnumSpec
{ es_options :: [EnumOption a]
}
jsonSerializer :: AllHave ToJSON as => HighSpec a ty as -> a -> Value
jsonSerializer hs val =
case hs_bodySpec hs of
BodySpecSum s -> object $ fst $ jsonSerSum s val
BodySpecRecord r -> object $ fst $ jsonSerRec r val
BodySpecEnum e -> toJSON $ jsonSerEnum e val
jsonEncoder :: AllHave ToJSON as => HighSpec a ty as -> a -> Encoding
jsonEncoder hs val =
case hs_bodySpec hs of
BodySpecSum s -> pairs $ snd $ jsonSerSum s val
BodySpecRecord r -> pairs $ snd $ jsonSerRec r val
BodySpecEnum e -> toEncoding $ jsonSerEnum e val
jsonSerEnum :: EnumSpec a -> a -> T.Text
jsonSerEnum (EnumSpec opts) val =
loop opts
where
loop [] = error "Empty enum spec"
loop (x : xs) =
case val ^? eo_prism x of
Just () -> eo_jsonKey x
Nothing -> loop xs
jsonSerSum :: forall a as. AllHave ToJSON as => SumSpec a as -> a -> ([Pair], Series)
jsonSerSum (SumSpec sopts) val =
loop sopts
where
loop ::
forall fs. AllHave ToJSON fs => SumOptions a fs -> ([Pair], Series)
loop flds =
case flds of
SOEmpty -> ([], mempty)
f :|: fs ->
case val ^? so_prism f of
Just body ->
let pair = (so_jsonKey f, toJSON body)
encoder = so_jsonKey f .= body
in ([pair], encoder)
Nothing -> loop fs
jsonSerRec :: forall a as. AllHave ToJSON as => RecordSpec a as -> a -> ([Pair], Series)
jsonSerRec (RecordSpec _ rflds) val =
loop rflds ([], mempty)
where
loop ::
forall fs. AllHave ToJSON fs
=> RecordFields a fs -> ([Pair], Series) -> ([Pair], Series)
loop flds accum@(ps, encoding) =
case flds of
RFEmpty -> accum
f :+: fs ->
let pair = (rf_jsonKey f, toJSON $ rf_get f val)
encoder = rf_jsonKey f .= rf_get f val
in loop fs ((pair : ps), encoder <> encoding)
jsonParser :: AllHave FromJSON as => HighSpec a ty as -> Value -> Parser a
jsonParser hs =
case hs_bodySpec hs of
BodySpecRecord r ->
withObject (T.unpack $ hs_name hs) (jsonParserRecord r)
BodySpecSum s ->
withObject (T.unpack $ hs_name hs) (jsonParserSum (hs_name hs) s)
BodySpecEnum e ->
withText (T.unpack $ hs_name hs) (jsonParserEnum (hs_name hs) e)
jsonParserRecord :: forall a as. AllHave FromJSON as => RecordSpec a as -> Object -> Parser a
jsonParserRecord (RecordSpec mk rflds) obj =
mk <$> loop rflds
where
loop :: forall fs. AllHave FromJSON fs => RecordFields a fs -> Parser (HVect fs)
loop flds =
case flds of
RFEmpty -> pure HNil
f :+: fs ->
let parse =
rf_jsonLoader f obj (rf_jsonKey f)
in do x <- parse
xs <- loop fs
pure (x :&: xs)
jsonParserSum :: forall a as. AllHave FromJSON as => T.Text -> SumSpec a as -> Object -> Parser a
jsonParserSum name (SumSpec sopts) obj =
loop sopts
where
loop :: forall os. AllHave FromJSON os => SumOptions a os -> Parser a
loop opts =
case opts of
SOEmpty ->
fail $
"Failed to parse as " ++ T.unpack name
o :|: os ->
let parse =
liftM (so_prism o #) $ obj .: so_jsonKey o
in parse <|> loop os
jsonParserEnum :: Monad m => T.Text -> EnumSpec a -> T.Text -> m a
jsonParserEnum name (EnumSpec sopts) t =
loop sopts
where
loop [] = fail $ "Failed to parse as " ++ T.unpack name
loop (x : xs) =
if t == eo_jsonKey x
then pure (eo_prism x # ())
else loop xs