{-# 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 = ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fun") (ExpQ -> ExpQ) -> ExpQ -> ExpQ
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
      Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only create encoders for an ADT, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a b. (Show a, StringConv String b) => a -> b
show Info
other)
      String -> ExpQ
forall a. String -> Q a
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 <- Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Cxt -> Cxt) -> ([Cxt] -> Cxt) -> [Cxt] -> Cxt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cxt] -> Cxt
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([Cxt] -> Cxt) -> Q [Cxt] -> Q Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con] -> (Con -> Q Cxt) -> Q [Cxt]
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 <- (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ThOptions -> Name -> Name
makeName ThOptions
thOptions) ([Name] -> [Name]) -> Q [Name] -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con] -> (Con -> Q Name) -> Q [Name]
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 = Q Pat -> Q Type -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"os")) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Options")
  let constructorEncoder :: Q Pat
constructorEncoder = Q Pat -> Q Type -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"ce")) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ConstructorEncoder")
  let encoderParameters :: [Q Pat]
encoderParameters = Q Pat
aesonOptions Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
: Q Pat
constructorEncoder Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
: ((\(Type
t, Integer
n) -> Q Pat -> Q Type -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"e" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a b. (Show a, StringConv String b) => a -> b
show Integer
n)) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t))) ((Type, Integer) -> Q Pat) -> [(Type, Integer)] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> [Integer] -> [(Type, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip Cxt
ts [Integer
0 ..])
  [Match]
matchClauses <- [Con] -> (Con -> Q Match) -> Q [Match]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs ((Con -> Q Match) -> Q [Match]) -> (Con -> Q Match) -> Q [Match]
forall a b. (a -> b) -> a -> b
$ ThOptions -> [Name] -> Cxt -> Con -> Q Match
makeMatchClause ThOptions
thOptions [Name]
constructorsNames Cxt
ts
  [Q Pat] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat]
encoderParameters (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
"Encoder")) ([Q Match] -> ExpQ
forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE (Match -> Q Match
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Q Match) -> [Match] -> [Q Match]
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 -> Q Match
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 (Name -> Name) -> Q Name -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Name
nameOf Con
c
  let names :: ExpQ
names = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> ExpQ) -> (Name -> Lit) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a b. (Show a, StringConv String b) => a -> b
show (Name -> String) -> (Name -> Name) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThOptions -> Name -> Name
makeName ThOptions
thOptions (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
constructorNames
  let types :: ExpQ
types = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> ExpQ) -> (Type -> Lit) -> Type -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Type -> String) -> Type -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
forall a b. (Show a, StringConv String b) => a -> b
show (Type -> ExpQ) -> Cxt -> [ExpQ]
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 = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> ExpQ) -> (Name -> Lit) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Name -> String) -> Name -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a b. (Show a, StringConv String b) => a -> b
show (Name -> String) -> (Name -> Name) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThOptions -> Name -> Name
makeName ThOptions
thOptions (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fields
  let params :: Q Pat
params = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a b. (Show a, StringConv String b) => a -> b
show Name
cName) ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (\(Type
_, Int
n, Int
_) -> Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"a" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
show Int
n)) ((Type, Int, Int) -> Q Pat) -> [(Type, Int, Int)] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, Int, Int)]
constructorTypes
  let values :: ExpQ
values = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (\(Type
_, Int
n, Int
k) -> ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"e" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
show Int
k))) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"a" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
show Int
n))) ((Type, Int, Int) -> ExpQ) -> [(Type, Int, Int)] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Type, Int, Int)]
constructorTypes
  let encoded :: ExpQ
encoded =
        Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"encodeConstructor")
          ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"ce")
          ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"os")
          ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
"FromConstructor") ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
names ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
types ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Lit -> ExpQ
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a b. (Show a, StringConv String b) => a -> b
show Name
cName) ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
fieldNames ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
values)
  Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
params (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
encoded) []