{-# 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 = 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) ->
      [Con] -> ExpQ
makeConstructorsEncoder [Con
constructor]
    TyConI (DataD Cxt
_context Name
_name [TyVarBndr ()]
_typeVars Maybe Type
_kind [Con]
constructors [DerivClause]
_deriving) ->
      [Con] -> ExpQ
makeConstructorsEncoder [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::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 <- 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 (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 :: Q Pat
options = 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
options 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
$ [Name] -> Cxt -> Con -> MatchQ
makeMatchClause [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 :: [Name] -> [Type] -> Con -> MatchQ
makeMatchClause :: [Name] -> Cxt -> Con -> MatchQ
makeMatchClause [Name]
constructorNames Cxt
allTypes Con
c = do
  Cxt
ts <- Con -> Q Cxt
typesOf Con
c
  [(Type, Int)]
constructorTypes <- Cxt -> Cxt -> Q [(Type, Int)]
indexConstructorTypes Cxt
allTypes Cxt
ts
  Name
cName <- Name -> Name
dropQualified 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
. Name -> Name
dropQualified 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
. Name -> Name
dropQualified 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) -> 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)]
constructorTypes
  let values :: ExpQ
values = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ (\(Type
_, Int
n) -> 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
n))) (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)]
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) []