{-# 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)
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"
makeConstructorsEncoder :: [Con] -> ExpQ
makeConstructorsEncoder :: [Con] -> ExpQ
makeConstructorsEncoder [Con]
cs = do
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)))
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) []