{-# OPTIONS_GHC -Wno-type-defaults #-}

module Data.Registry.Aeson.TH.Encoder where

import Control.Monad.Fail
import Data.List (nub)
import Data.Registry.Aeson.TH.ThOptions
import Data.Registry.Aeson.TH.TH
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Protolude as P hiding (Type)

{-
  This module uses TemplateHaskell to extract enough type information to be able to
  build an Encoder based on configuration options
-}

-- | Make an Encoder for a given data type
--   Usage: $(makeEncoder ''MyDataType <: otherEncoders)
makeEncoder :: Name -> ExpQ
makeEncoder :: Name -> ExpQ
makeEncoder = ThOptions -> Name -> ExpQ
makeEncoderWith ThOptions
defaultThOptions

-- | Make an Encoder for a given data type, where all types names are qualified with their module full name
--   Usage:
--    -- MyDataType is defined in X.Y.Z
--    import X.Y.Z qualified
--    $(makeEncoderQualified ''MyDataType <: otherEncoders)
makeEncoderQualified :: Name -> ExpQ
makeEncoderQualified :: Name -> ExpQ
makeEncoderQualified = ThOptions -> Name -> ExpQ
makeEncoderWith ((Text -> Text) -> ThOptions
ThOptions Text -> Text
qualified)

-- | Make an Encoder for a given data type, where all types names are qualified with their module name
--    -- MyDataType is defined in X.Y.Z
--    import X.Y.Z qualified as Z
--    $(makeEncoderQualifiedLast ''MyDataType <: otherEncoders)
makeEncoderQualifiedLast :: Name -> ExpQ
makeEncoderQualifiedLast :: Name -> ExpQ
makeEncoderQualifiedLast = ThOptions -> Name -> ExpQ
makeEncoderWith ((Text -> Text) -> ThOptions
ThOptions Text -> Text
qualifyWithLastName)

-- | Make an Encoder for a given data type  and pass options to specify how names must be qualified
--   Usage: $(makeEncoderWith options ''MyDataType) <: otherEncoders
makeEncoderWith :: ThOptions -> Name -> ExpQ
makeEncoderWith :: ThOptions -> Name -> ExpQ
makeEncoderWith ThOptions
thOptions Name
encodedType = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fun") forall a b. (a -> b) -> a -> b
$ do
  Info
info <- Name -> Q Info
reify Name
encodedType
  case Info
info of
    TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr ()]
_typeVars Maybe Type
_kind Con
constructor [DerivClause]
_deriving) ->
      ThOptions -> [Con] -> ExpQ
makeConstructorsEncoder ThOptions
thOptions [Con
constructor]
    TyConI (DataD Cxt
_context Name
_name [TyVarBndr ()]
_typeVars Maybe Type
_kind [Con]
constructors [DerivClause]
_deriving) ->
      ThOptions -> [Con] -> ExpQ
makeConstructorsEncoder ThOptions
thOptions [Con]
constructors
    Info
other -> do
      forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only create encoders for an ADT, got: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Info
other)
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"encoders creation failed"

-- \(o::ThOptions) (ce::ConstructorEncoder) (e0::Encoder A0) (e1::Encoder A1) ... -> Encoder $ \a ->
--   case a of
--     T1 a0 a1 ... -> encodeConstructor ce o (FromConstructor names types "T1" fieldNames [encode e0 a0, encode e1 a1, ...])
--     T2 a0 a4 ... -> encodeConstructor ce o (FromConstructor names types "T2" fieldNames [encode e0 a0, encode e4 a4, ...])
makeConstructorsEncoder :: ThOptions -> [Con] -> ExpQ
makeConstructorsEncoder :: ThOptions -> [Con] -> ExpQ
makeConstructorsEncoder ThOptions
thOptions [Con]
cs = do
  -- get the types of all the fields of all the constructors
  Cxt
ts <- forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs Con -> Q Cxt
typesOf
  [Name]
constructorsNames <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ThOptions -> Name -> Name
makeName ThOptions
thOptions) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs Con -> Q Name
nameOf
  let aesonOptions :: Q Pat
aesonOptions = forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"os")) (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Options")
  let constructorEncoder :: Q Pat
constructorEncoder = forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"ce")) (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ConstructorEncoder")
  let encoderParameters :: [Q Pat]
encoderParameters = Q Pat
aesonOptions forall a. a -> [a] -> [a]
: Q Pat
constructorEncoder forall a. a -> [a] -> [a]
: ((\(Type
t, Integer
n) -> forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"e" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Integer
n)) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
ts [Integer
0 ..])
  [Match]
matchClauses <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs forall a b. (a -> b) -> a -> b
$ ThOptions -> [Name] -> Cxt -> Con -> MatchQ
makeMatchClause ThOptions
thOptions [Name]
constructorsNames Cxt
ts
  forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat]
encoderParameters (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
"Encoder")) (forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Match]
matchClauses)))

-- | Make the match clause for a constructor given
--    - the list of all the encoder types
--    - the constructor name
--    - the constructor index in the list of all the constructors for the encoded data type
--   T1 a0 a1 ... -> encodeConstructor ce o (FromConstructor names types cName fieldNames values)
makeMatchClause :: ThOptions -> [Name] -> [Type] -> Con -> MatchQ
makeMatchClause :: ThOptions -> [Name] -> Cxt -> Con -> MatchQ
makeMatchClause ThOptions
thOptions [Name]
constructorNames Cxt
allTypes Con
c = do
  Cxt
ts <- Con -> Q Cxt
typesOf Con
c
  [(Type, Int, Int)]
constructorTypes <- Cxt -> Cxt -> Q [(Type, Int, Int)]
indexConstructorTypes Cxt
allTypes Cxt
ts
  Name
cName <- ThOptions -> Name -> Name
makeName ThOptions
thOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
  let names :: ExpQ
names = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv String b) => a -> b
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThOptions -> Name -> Name
makeName ThOptions
thOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
constructorNames
  let types :: ExpQ
types = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv String b) => a -> b
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt
allTypes
  [Name]
fields <- Con -> Q [Name]
fieldsOf Con
c
  let fieldNames :: ExpQ
fieldNames = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv String b) => a -> b
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThOptions -> Name -> Name
makeName ThOptions
thOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fields
  let params :: Q Pat
params = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, StringConv String b) => a -> b
show Name
cName) forall a b. (a -> b) -> a -> b
$ (\(Type
_, Int
n, Int
_) -> forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"a" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, Int, Int)]
constructorTypes
  let values :: ExpQ
values = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ (\(Type
_, Int
n, Int
k) -> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"e" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
k))) (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"a" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, Int, Int)]
constructorTypes
  let encoded :: ExpQ
encoded =
        forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"encodeConstructor")
          forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"ce")
          forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"os")
          forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
"FromConstructor") forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
names forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
types forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, StringConv String b) => a -> b
show Name
cName) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
fieldNames forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
values)
  forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
params (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
encoded) []