{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
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 Data.Aeson
import Data.Aeson.Types hiding (parse)
import Data.HVect
import qualified Data.Text as T

data SpecType
    = SpecRecord
    | SpecSum
    | SpecEnum

data HighSpec a (ty :: SpecType) as
    = HighSpec
    { HighSpec a ty as -> Text
hs_name :: !T.Text
    , HighSpec a ty as -> Maybe Text
hs_description :: !(Maybe T.Text)
    , HighSpec a ty as -> BodySpec ty a as
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
    { RecordField t f -> Text
rf_jsonKey :: !T.Text
    , RecordField t f -> Bool
rf_optional :: !Bool
    , RecordField t f -> Object -> Text -> Parser f
rf_jsonLoader :: Object -> T.Text -> Parser f
    , RecordField t f -> t -> f
rf_get :: !(t -> f)
    }

data RecordSpec a fs
    = RecordSpec
    { RecordSpec a fs -> HVect fs -> a
rs_make :: HVect fs -> a
    , RecordSpec a fs -> RecordFields a fs
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
    { SumOption t o -> Text
so_jsonKey :: !T.Text
    , SumOption t o
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p o (f o) -> p t (f t)
so_prism :: !(Prism' t o)
    }

data SumSpec a os
    = SumSpec
    { SumSpec a os -> SumOptions a os
ss_options :: SumOptions a os
    }

data EnumOption t
    = EnumOption
    { EnumOption t -> Text
eo_jsonKey :: !T.Text
    , EnumOption t
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p () (f ()) -> p t (f t)
eo_prism :: !(Prism' t ())
    }

data EnumSpec a
    = EnumSpec
    { EnumSpec a -> [EnumOption a]
es_options :: [EnumOption a]
    }

jsonSerializer :: AllHave ToJSON as => HighSpec a ty as -> a -> Value
jsonSerializer :: HighSpec a ty as -> a -> Value
jsonSerializer HighSpec a ty as
hs a
val =
    case HighSpec a ty as -> BodySpec ty a as
forall a (ty :: SpecType) (as :: [*]).
HighSpec a ty as -> BodySpec ty a as
hs_bodySpec HighSpec a ty as
hs of
      BodySpecSum SumSpec a as
s -> [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ ([Pair], Series) -> [Pair]
forall a b. (a, b) -> a
fst (([Pair], Series) -> [Pair]) -> ([Pair], Series) -> [Pair]
forall a b. (a -> b) -> a -> b
$ SumSpec a as -> a -> ([Pair], Series)
forall a (as :: [*]).
AllHave ToJSON as =>
SumSpec a as -> a -> ([Pair], Series)
jsonSerSum SumSpec a as
s a
val
      BodySpecRecord RecordSpec a as
r -> [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ ([Pair], Series) -> [Pair]
forall a b. (a, b) -> a
fst (([Pair], Series) -> [Pair]) -> ([Pair], Series) -> [Pair]
forall a b. (a -> b) -> a -> b
$ RecordSpec a as -> a -> ([Pair], Series)
forall a (as :: [*]).
AllHave ToJSON as =>
RecordSpec a as -> a -> ([Pair], Series)
jsonSerRec RecordSpec a as
r a
val
      BodySpecEnum EnumSpec a
e -> Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text -> EnumSpec a -> a -> Text
forall a. Text -> EnumSpec a -> a -> Text
jsonSerEnum (HighSpec a ty as -> Text
forall a (ty :: SpecType) (as :: [*]). HighSpec a ty as -> Text
hs_name HighSpec a ty as
hs) EnumSpec a
e a
val

jsonEncoder :: AllHave ToJSON as => HighSpec a ty as -> a -> Encoding
jsonEncoder :: HighSpec a ty as -> a -> Encoding
jsonEncoder HighSpec a ty as
hs a
val =
    case HighSpec a ty as -> BodySpec ty a as
forall a (ty :: SpecType) (as :: [*]).
HighSpec a ty as -> BodySpec ty a as
hs_bodySpec HighSpec a ty as
hs of
      BodySpecSum SumSpec a as
s -> Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ ([Pair], Series) -> Series
forall a b. (a, b) -> b
snd (([Pair], Series) -> Series) -> ([Pair], Series) -> Series
forall a b. (a -> b) -> a -> b
$ SumSpec a as -> a -> ([Pair], Series)
forall a (as :: [*]).
AllHave ToJSON as =>
SumSpec a as -> a -> ([Pair], Series)
jsonSerSum SumSpec a as
s a
val
      BodySpecRecord RecordSpec a as
r -> Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ ([Pair], Series) -> Series
forall a b. (a, b) -> b
snd (([Pair], Series) -> Series) -> ([Pair], Series) -> Series
forall a b. (a -> b) -> a -> b
$ RecordSpec a as -> a -> ([Pair], Series)
forall a (as :: [*]).
AllHave ToJSON as =>
RecordSpec a as -> a -> ([Pair], Series)
jsonSerRec RecordSpec a as
r a
val
      BodySpecEnum EnumSpec a
e -> Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Text -> Encoding) -> Text -> Encoding
forall a b. (a -> b) -> a -> b
$ Text -> EnumSpec a -> a -> Text
forall a. Text -> EnumSpec a -> a -> Text
jsonSerEnum (HighSpec a ty as -> Text
forall a (ty :: SpecType) (as :: [*]). HighSpec a ty as -> Text
hs_name HighSpec a ty as
hs) EnumSpec a
e a
val

jsonSerEnum :: T.Text -> EnumSpec a -> a -> T.Text
jsonSerEnum :: Text -> EnumSpec a -> a -> Text
jsonSerEnum Text
enumName (EnumSpec [EnumOption a]
opts) a
val =
    [EnumOption a] -> Text
loop [EnumOption a]
opts
    where
      loop :: [EnumOption a] -> Text
loop [] =
          [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Empty enum spec for " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
enumName [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
". Did you mention all cases?"
      loop (EnumOption a
x : [EnumOption a]
xs) =
          case a
val a -> Getting (First ()) a () -> Maybe ()
forall s a. s -> Getting (First a) s a -> Maybe a
^? EnumOption a
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p () (f ()) -> p a (f a)
forall t.
EnumOption t
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p () (f ()) -> p t (f t)
eo_prism EnumOption a
x of
            Just () -> EnumOption a -> Text
forall t. EnumOption t -> Text
eo_jsonKey EnumOption a
x
            Maybe ()
Nothing -> [EnumOption a] -> Text
loop [EnumOption a]
xs

jsonSerSum :: forall a as. AllHave ToJSON as => SumSpec a as -> a -> ([Pair], Series)
jsonSerSum :: SumSpec a as -> a -> ([Pair], Series)
jsonSerSum (SumSpec SumOptions a as
sopts) a
val =
    SumOptions a as -> ([Pair], Series)
forall (fs :: [*]).
AllHave ToJSON fs =>
SumOptions a fs -> ([Pair], Series)
loop SumOptions a as
sopts
    where
      loop ::
          forall fs. AllHave ToJSON fs => SumOptions a fs -> ([Pair], Series)
      loop :: SumOptions a fs -> ([Pair], Series)
loop SumOptions a fs
flds =
          case SumOptions a fs
flds of
            SumOptions a fs
SOEmpty -> ([], Series
forall a. Monoid a => a
mempty)
            SumOption a o
f :|: SumOptions a os
fs ->
                case a
val a -> Getting (First o) a o -> Maybe o
forall s a. s -> Getting (First a) s a -> Maybe a
^? SumOption a o
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p o (f o) -> p a (f a)
forall t o.
SumOption t o
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p o (f o) -> p t (f t)
so_prism SumOption a o
f of
                  Just o
body ->
                      let pair :: Pair
pair = (SumOption a o -> Text
forall t o. SumOption t o -> Text
so_jsonKey SumOption a o
f, o -> Value
forall a. ToJSON a => a -> Value
toJSON o
body)
                          encoder :: Series
encoder = SumOption a o -> Text
forall t o. SumOption t o -> Text
so_jsonKey SumOption a o
f Text -> o -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= o
body
                      in ([Pair
pair], Series
encoder)
                  Maybe o
Nothing -> SumOptions a os -> ([Pair], Series)
forall (fs :: [*]).
AllHave ToJSON fs =>
SumOptions a fs -> ([Pair], Series)
loop SumOptions a os
fs

jsonSerRec :: forall a as. AllHave ToJSON as => RecordSpec a as -> a -> ([Pair], Series)
jsonSerRec :: RecordSpec a as -> a -> ([Pair], Series)
jsonSerRec (RecordSpec HVect as -> a
_ RecordFields a as
rflds) a
val =
    RecordFields a as -> ([Pair], Series) -> ([Pair], Series)
forall (fs :: [*]).
AllHave ToJSON fs =>
RecordFields a fs -> ([Pair], Series) -> ([Pair], Series)
loop RecordFields a as
rflds ([], Series
forall a. Monoid a => a
mempty)
    where
      loop ::
          forall fs. AllHave ToJSON fs
          => RecordFields a fs -> ([Pair], Series) -> ([Pair], Series)
      loop :: RecordFields a fs -> ([Pair], Series) -> ([Pair], Series)
loop RecordFields a fs
flds accum :: ([Pair], Series)
accum@([Pair]
ps, Series
encoding) =
          case RecordFields a fs
flds of
            RecordFields a fs
RFEmpty -> ([Pair], Series)
accum
            RecordField a f
f :+: RecordFields a fs
fs ->
                let pair :: Pair
pair = (RecordField a f -> Text
forall t f. RecordField t f -> Text
rf_jsonKey RecordField a f
f, f -> Value
forall a. ToJSON a => a -> Value
toJSON (f -> Value) -> f -> Value
forall a b. (a -> b) -> a -> b
$ RecordField a f -> a -> f
forall t f. RecordField t f -> t -> f
rf_get RecordField a f
f a
val)
                    encoder :: Series
encoder = RecordField a f -> Text
forall t f. RecordField t f -> Text
rf_jsonKey RecordField a f
f Text -> f -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= RecordField a f -> a -> f
forall t f. RecordField t f -> t -> f
rf_get RecordField a f
f a
val
                in RecordFields a fs -> ([Pair], Series) -> ([Pair], Series)
forall (fs :: [*]).
AllHave ToJSON fs =>
RecordFields a fs -> ([Pair], Series) -> ([Pair], Series)
loop RecordFields a fs
fs (Pair
pair Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
ps, Series
encoder Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Series
encoding)

jsonParser :: AllHave FromJSON as => HighSpec a ty as -> Value -> Parser a
jsonParser :: HighSpec a ty as -> Value -> Parser a
jsonParser HighSpec a ty as
hs =
    case HighSpec a ty as -> BodySpec ty a as
forall a (ty :: SpecType) (as :: [*]).
HighSpec a ty as -> BodySpec ty a as
hs_bodySpec HighSpec a ty as
hs of
      BodySpecRecord RecordSpec a as
r ->
          [Char] -> (Object -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject (Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ HighSpec a ty as -> Text
forall a (ty :: SpecType) (as :: [*]). HighSpec a ty as -> Text
hs_name HighSpec a ty as
hs) (RecordSpec a as -> Object -> Parser a
forall a (as :: [*]).
AllHave FromJSON as =>
RecordSpec a as -> Object -> Parser a
jsonParserRecord RecordSpec a as
r)
      BodySpecSum SumSpec a as
s ->
          [Char] -> (Object -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject (Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ HighSpec a ty as -> Text
forall a (ty :: SpecType) (as :: [*]). HighSpec a ty as -> Text
hs_name HighSpec a ty as
hs) (Text -> SumSpec a as -> Object -> Parser a
forall a (as :: [*]).
AllHave FromJSON as =>
Text -> SumSpec a as -> Object -> Parser a
jsonParserSum (HighSpec a ty as -> Text
forall a (ty :: SpecType) (as :: [*]). HighSpec a ty as -> Text
hs_name HighSpec a ty as
hs) SumSpec a as
s)
      BodySpecEnum EnumSpec a
e ->
          [Char] -> (Text -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText (Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ HighSpec a ty as -> Text
forall a (ty :: SpecType) (as :: [*]). HighSpec a ty as -> Text
hs_name HighSpec a ty as
hs) (Text -> EnumSpec a -> Text -> Parser a
forall (m :: * -> *) a.
(MonadFail m, Monad m) =>
Text -> EnumSpec a -> Text -> m a
jsonParserEnum (HighSpec a ty as -> Text
forall a (ty :: SpecType) (as :: [*]). HighSpec a ty as -> Text
hs_name HighSpec a ty as
hs) EnumSpec a
e)

jsonParserRecord :: forall a as. AllHave FromJSON as => RecordSpec a as -> Object -> Parser a
jsonParserRecord :: RecordSpec a as -> Object -> Parser a
jsonParserRecord (RecordSpec HVect as -> a
mk RecordFields a as
rflds) Object
obj =
    HVect as -> a
mk (HVect as -> a) -> Parser (HVect as) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecordFields a as -> Parser (HVect as)
forall (fs :: [*]).
AllHave FromJSON fs =>
RecordFields a fs -> Parser (HVect fs)
loop RecordFields a as
rflds
    where
      loop :: forall fs. AllHave FromJSON fs => RecordFields a fs -> Parser (HVect fs)
      loop :: RecordFields a fs -> Parser (HVect fs)
loop RecordFields a fs
flds =
          case RecordFields a fs
flds of
            RecordFields a fs
RFEmpty -> HVect '[] -> Parser (HVect '[])
forall (f :: * -> *) a. Applicative f => a -> f a
pure HVect '[]
HNil
            RecordField a f
f :+: RecordFields a fs
fs ->
                let parse :: Parser f
parse =
                        RecordField a f -> Object -> Text -> Parser f
forall t f. RecordField t f -> Object -> Text -> Parser f
rf_jsonLoader RecordField a f
f Object
obj (RecordField a f -> Text
forall t f. RecordField t f -> Text
rf_jsonKey RecordField a f
f)
                in do f
x <- Parser f
parse
                      HVect fs
xs <- RecordFields a fs -> Parser (HVect fs)
forall (fs :: [*]).
AllHave FromJSON fs =>
RecordFields a fs -> Parser (HVect fs)
loop RecordFields a fs
fs
                      HVect (f : fs) -> Parser (HVect (f : fs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
x f -> HVect fs -> HVect (f : fs)
forall t (ts1 :: [*]). t -> HVect ts1 -> HVect (t : ts1)
:&: HVect fs
xs)

jsonParserSum :: forall a as. AllHave FromJSON as => T.Text -> SumSpec a as -> Object -> Parser a
jsonParserSum :: Text -> SumSpec a as -> Object -> Parser a
jsonParserSum Text
name (SumSpec SumOptions a as
sopts) Object
obj =
    SumOptions a as -> Parser a
forall (os :: [*]).
AllHave FromJSON os =>
SumOptions a os -> Parser a
loop SumOptions a as
sopts
    where
      loop :: forall os. AllHave FromJSON os => SumOptions a os -> Parser a
      loop :: SumOptions a os -> Parser a
loop SumOptions a os
opts =
          case SumOptions a os
opts of
            SumOptions a os
SOEmpty ->
                [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser a) -> [Char] -> Parser a
forall a b. (a -> b) -> a -> b
$
                [Char]
"Failed to parse as " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
name
            SumOption a o
o :|: SumOptions a os
os ->
                let parse :: Parser a
parse =
                        (o -> a) -> Parser o -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SumOption a o
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p o (f o) -> p a (f a)
forall t o.
SumOption t o
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p o (f o) -> p t (f t)
so_prism SumOption a o
o (Tagged o (Identity o) -> Tagged a (Identity a)) -> o -> a
forall t b. AReview t b -> b -> t
#) (Parser o -> Parser a) -> Parser o -> Parser a
forall a b. (a -> b) -> a -> b
$ Object
obj Object -> Text -> Parser o
forall a. FromJSON a => Object -> Text -> Parser a
.: SumOption a o -> Text
forall t o. SumOption t o -> Text
so_jsonKey SumOption a o
o
                in Parser a
parse Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SumOptions a os -> Parser a
forall (os :: [*]).
AllHave FromJSON os =>
SumOptions a os -> Parser a
loop SumOptions a os
os


jsonParserEnum :: (MonadFail m, Monad m) => T.Text -> EnumSpec a -> T.Text -> m a
jsonParserEnum :: Text -> EnumSpec a -> Text -> m a
jsonParserEnum Text
name (EnumSpec [EnumOption a]
sopts) Text
t =
    [EnumOption a] -> m a
loop [EnumOption a]
sopts
    where
      loop :: [EnumOption a] -> m a
loop [] = [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to parse as " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
name
      loop (EnumOption a
x : [EnumOption a]
xs) =
          if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== EnumOption a -> Text
forall t. EnumOption t -> Text
eo_jsonKey EnumOption a
x
          then a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnumOption a
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p () (f ()) -> p a (f a)
forall t.
EnumOption t
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p () (f ()) -> p t (f t)
eo_prism EnumOption a
x (Tagged () (Identity ()) -> Tagged a (Identity a)) -> () -> a
forall t b. AReview t b -> b -> t
# ())
          else [EnumOption a] -> m a
loop [EnumOption a]
xs