{-# 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.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 Name
encodedType = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
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 Kind
_kind Con
constructor [DerivClause]
_deriving) ->
      [Con] -> ExpQ
makeConstructorsEncoder [Con
constructor]
    TyConI (DataD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind [Con]
constructors [DerivClause]
_deriving) ->
      [Con] -> ExpQ
makeConstructorsEncoder [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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"encoders creation failed"

-- \(o::Options) (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 :: [Con] -> ExpQ
makeConstructorsEncoder :: [Con] -> ExpQ
makeConstructorsEncoder [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 <- [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 options :: PatQ
options = PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName String
"os")) (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Options")
  let constructorEncoder :: PatQ
constructorEncoder = PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName String
"ce")) (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ConstructorEncoder")
  let encoderParameters :: [PatQ]
encoderParameters = PatQ
options PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: PatQ
constructorEncoder PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: ((\(Kind
t, Integer
n) -> PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
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)) (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Encoder") (Kind -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
t))) ((Kind, Integer) -> PatQ) -> [(Kind, Integer)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> [Integer] -> [(Kind, 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
$ [Name] -> Cxt -> Con -> Q Match
makeMatchClause [Name]
constructorsNames Cxt
ts
  [PatQ] -> ExpQ -> ExpQ
lamE [PatQ]
encoderParameters (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (String -> Name
mkName String
"Encoder")) ([Q Match] -> ExpQ
lamCaseE (Match -> Q Match
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 :: [Name] -> [Type] -> Con -> MatchQ
makeMatchClause :: [Name] -> Cxt -> Con -> Q Match
makeMatchClause [Name]
constructorNames Cxt
allTypes Con
c = do
  Cxt
ts <- Con -> Q Cxt
typesOf Con
c
  [(Kind, Int)]
constructorTypes <- Cxt -> Cxt -> Q [(Kind, Int)]
indexConstructorTypes Cxt
allTypes Cxt
ts
  Name
cName <- Name -> Name
dropQualified (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
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
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
. Name -> Name
dropQualified (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
constructorNames
  let types :: ExpQ
types = [ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
litE (Lit -> ExpQ) -> (Kind -> Lit) -> Kind -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Lit) -> (Kind -> String) -> Kind -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> String
forall a b. (Show a, StringConv String b) => a -> b
show (Kind -> 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
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ Lit -> ExpQ
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
. Name -> Name
dropQualified (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fields
  let params :: PatQ
params = Name -> [PatQ] -> PatQ
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) ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (\(Kind
_, Int
n) -> Name -> PatQ
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)) ((Kind, Int) -> PatQ) -> [(Kind, Int)] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Kind, Int)]
constructorTypes
  let values :: ExpQ
values = [ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (\(Kind
_, Int
n) -> ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"encode") (Name -> ExpQ
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
n))) (Name -> ExpQ
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))) ((Kind, Int) -> ExpQ) -> [(Kind, Int)] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Kind, Int)]
constructorTypes
  let encoded :: ExpQ
encoded =
        Name -> ExpQ
varE (String -> Name
mkName String
"encodeConstructor")
          ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"ce")
          ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"os")
          ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
conE (String -> Name
mkName String
"FromConstructor") ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
names ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
types ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
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
`appE` ExpQ
fieldNames ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
values)
  PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
params (ExpQ -> BodyQ
normalB ExpQ
encoded) []