{-# OPTIONS_GHC -Wno-type-defaults #-}
module Data.Registry.Aeson.TH.Decoder 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)
makeDecoder :: Name -> ExpQ
makeDecoder :: Name -> ExpQ
makeDecoder Name
typeName = 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
typeName
case Info
info of
TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind Con
constructor [DerivClause]
_deriving) ->
Name -> [Con] -> ExpQ
makeConstructorsDecoder Name
typeName [Con
constructor]
TyConI (DataD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind [Con]
constructors [DerivClause]
_deriving) -> do
case [Con]
constructors of
[] -> do
Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True String
"can not make an Decoder for an empty data type"
String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decoders creation failed"
[Con]
_ -> Name -> [Con] -> ExpQ
makeConstructorsDecoder Name
typeName [Con]
constructors
Info
other -> do
Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only create decoders 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
P.show Info
other)
String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"decoders creation failed"
makeConstructorsDecoder :: Name -> [Con] -> ExpQ
makeConstructorsDecoder :: Name -> [Con] -> ExpQ
makeConstructorsDecoder Name
typeName [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
let decoderParameters :: [PatQ]
decoderParameters = 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") PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: PatQ -> TypeQ -> PatQ
sigP (Name -> PatQ
varP (String -> Name
mkName String
"cd")) (Name -> TypeQ
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ConstructorsDecoder") 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
"d" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a b. (Show a, StringConv String b) => a -> b
P.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
"Decoder") (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 ..])
let paramP :: PatQ
paramP = Name -> PatQ
varP (String -> Name
mkName String
"v")
[Exp]
constructorDefs <- [Con] -> (Con -> ExpQ) -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs ((Con -> ExpQ) -> Q [Exp]) -> (Con -> ExpQ) -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ \Con
c -> do
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
[ExpQ]
fields <- (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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
P.show (Name -> String) -> (Name -> Name) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
dropQualified) ([Name] -> [ExpQ]) -> Q [Name] -> Q [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q [Name]
fieldsOf Con
c
[ExpQ]
fieldTypes <- (Kind -> ExpQ) -> Cxt -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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
. Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show (Name -> String) -> (Kind -> Name) -> Kind -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Name
getSimpleTypeName) (Cxt -> [ExpQ]) -> Q Cxt -> Q [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Con -> Q Cxt
typesOf Con
c
Name -> ExpQ
varE (String -> Name
mkName String
"makeConstructorDef") ExpQ -> ExpQ -> ExpQ
`appE` (Lit -> ExpQ
litE (Lit -> ExpQ) -> (String -> Lit) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Name
cName) ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE [ExpQ]
fields ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE [ExpQ]
fieldTypes
let matchClauses :: [MatchQ]
matchClauses = Name -> Cxt -> Con -> MatchQ
makeMatchClause Name
typeName Cxt
ts (Con -> MatchQ) -> [Con] -> [MatchQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
cs
let matchFunction :: ExpQ
matchFunction = [MatchQ] -> ExpQ
lamCaseE ([MatchQ]
matchClauses [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. Semigroup a => a -> a -> a
<> [Name -> MatchQ
makeErrorClause Name
typeName])
let resolveFunction :: ExpQ
resolveFunction = Name -> ExpQ
varE (String -> Name
mkName String
"decodeFromDefinitions") ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"os") ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"cd") ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE (Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> [Exp] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Exp]
constructorDefs) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"v") ExpQ -> ExpQ -> ExpQ
`appE` ExpQ
matchFunction
[PatQ] -> ExpQ -> ExpQ
lamE [PatQ]
decoderParameters (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (String -> Name
mkName String
"Decoder")) ([PatQ] -> ExpQ -> ExpQ
lamE [PatQ
paramP] ExpQ
resolveFunction))
makeMatchClause :: Name -> [Type] -> Con -> MatchQ
makeMatchClause :: Name -> Cxt -> Con -> MatchQ
makeMatchClause Name
typeName Cxt
allTypes Con
c = do
Cxt
ts <- Con -> Q Cxt
typesOf Con
c
[Int]
constructorTypes <- ((Kind, Int) -> Int) -> [(Kind, Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Kind, Int) -> Int
forall a b. (a, b) -> b
snd ([(Kind, Int)] -> [Int]) -> Q [(Kind, Int)] -> Q [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 fieldsP :: PatQ
fieldsP = [PatQ] -> PatQ
listP ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (\Int
i -> Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Int
i)) (Int -> PatQ) -> [Int] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
constructorTypes
PatQ -> BodyQ -> [DecQ] -> MatchQ
match
(Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
"ToConstructor") [Lit -> PatQ
litP (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
P.show (Name -> Lit) -> Name -> Lit
forall a b. (a -> b) -> a -> b
$ Name
cName), PatQ
fieldsP])
(ExpQ -> BodyQ
normalB (Name -> Name -> [Int] -> ExpQ
applyDecoder Name
typeName Name
cName [Int]
constructorTypes))
[]
makeErrorClause :: Name -> MatchQ
makeErrorClause :: Name -> MatchQ
makeErrorClause Name
typeName = do
let errorMessage :: ExpQ
errorMessage =
(Name -> ExpQ
varE (String -> Name
mkName String
"<>") ExpQ -> ExpQ -> ExpQ
`appE` Lit -> ExpQ
litE (String -> Lit
StringL (String
"cannot use this constructor to create an instance of type '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Name
typeName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"': ")))
ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
varE (String -> Name
mkName String
"show") ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName String
"_1"))
PatQ -> BodyQ -> [DecQ] -> MatchQ
match (Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"_1") (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Left") ExpQ
errorMessage)) []
applyDecoder :: Name -> Name -> [Int] -> ExpQ
applyDecoder :: Name -> Name -> [Int] -> ExpQ
applyDecoder Name
_typeName Name
cName [] = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pure") (Name -> ExpQ
conE Name
cName)
applyDecoder Name
typeName Name
cName (Int
n : [Int]
ns) = do
let cons :: ExpQ
cons = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pure") (Name -> ExpQ
conE Name
cName)
(Int -> ExpQ -> ExpQ) -> ExpQ -> [Int] -> ExpQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
i ExpQ
r -> ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"ap")) ExpQ
r) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Int -> ExpQ
decodeAt Int
i) (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE (String -> Name
mkName String
"ap")) ExpQ
cons) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ Int -> ExpQ
decodeAt Int
n) ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
ns)
where
decodeAt :: Int -> ExpQ
decodeAt Int
i =
Name -> ExpQ
varE (String -> Name
mkName String
"decodeFieldValue") ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName (String
"d" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Int
i))
ExpQ -> ExpQ -> ExpQ
`appE` (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
P.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 a b. (a -> b) -> a -> b
$ Name
typeName)
ExpQ -> ExpQ -> ExpQ
`appE` (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
P.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 a b. (a -> b) -> a -> b
$ Name
cName)
ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE (String -> Name
mkName (String
"v" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
P.show Int
i))