-- | This module exports the templates for automatic instance deriving of "Rank2" type classes. The most common way to
-- use it would be
--
-- > import qualified Rank2.TH
-- > data MyDataType f = ...
-- > $(Rank2.TH.deriveAll ''MyDataType)
--
-- or, if you're picky, you can invoke only 'deriveFunctor' and whichever other instances you need instead.
{-# Language CPP #-}
{-# Language TemplateHaskell #-}
{-# Language TypeOperators #-}
-- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial
module Rank2.TH (deriveAll, deriveFunctor, deriveApply, unsafeDeriveApply, deriveApplicative,
deriveFoldable, deriveTraversable,
deriveDistributive, deriveDistributiveTraversable, deriveLogistic)
where
import Control.Applicative (liftA2, liftA3)
import Control.Monad (replicateM)
import Data.Bifunctor (first)
import Data.Distributive (cotraverse)
import Data.Functor.Compose (Compose (Compose))
import Data.Functor.Contravariant (Contravariant, contramap)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH (Q, TypeQ, Name, TyVarBndr(KindedTV, PlainTV), Clause, Dec(..), Con(..), Type(..), Exp(..),
Inline(Inlinable, Inline), RuleMatch(FunLike), Phases(AllPhases),
appE, conE, conP, conT, instanceD, varE, varP, varT, normalB, pragInlD, recConE, wildP)
import Language.Haskell.TH.Syntax (BangType, VarBangType, Info(TyConI), getQ, putQ, newName)
import qualified Rank2
data Deriving = Deriving { _derivingConstructor :: Name, _derivingVariable :: Name } deriving Show
deriveAll :: Name -> Q [Dec]
deriveAll ty = foldr f (pure []) [deriveFunctor, deriveApply, deriveApplicative,
deriveFoldable, deriveTraversable,
deriveDistributive, deriveDistributiveTraversable, deriveLogistic]
where f derive rest = (<>) <$> derive ty <*> rest
deriveFunctor :: Name -> Q [Dec]
deriveFunctor ty = do
(instanceType, cs) <- reifyConstructors ''Rank2.Functor ty
(constraints, dec) <- genFmap instanceType cs
sequence [instanceD (TH.cxt $ map pure constraints) instanceType
[pure dec, pragInlD '(Rank2.<$>) Inline FunLike AllPhases]]
deriveApply :: Name -> Q [Dec]
deriveApply ty = do
(instanceType, cs) <- reifyConstructors ''Rank2.Apply ty
(constraints, dec) <- genAp instanceType cs
sequence [instanceD (TH.cxt $ map pure constraints) instanceType
[pure dec, genLiftA2 cs, genLiftA3 cs,
pragInlD '(Rank2.<*>) Inlinable FunLike AllPhases,
pragInlD 'Rank2.liftA2 Inlinable FunLike AllPhases]]
-- | This function always succeeds, but the methods it generates may be partial. Use with care.
unsafeDeriveApply :: Name -> Q [Dec]
unsafeDeriveApply ty = do
(instanceType, cs) <- reifyConstructors ''Rank2.Apply ty
(constraints, dec) <- genApUnsafely instanceType cs
sequence [instanceD (TH.cxt $ map pure constraints) instanceType
[pure dec, genLiftA2Unsafely cs, genLiftA3Unsafely cs,
pragInlD '(Rank2.<*>) Inlinable FunLike AllPhases,
pragInlD 'Rank2.liftA2 Inlinable FunLike AllPhases]]
deriveApplicative :: Name -> Q [Dec]
deriveApplicative ty = do
(instanceType, cs) <- reifyConstructors ''Rank2.Applicative ty
(constraints, dec) <- genPure cs
sequence [instanceD (TH.cxt $ map pure constraints) instanceType
[pure dec, pragInlD 'Rank2.pure Inline FunLike AllPhases]]
deriveFoldable :: Name -> Q [Dec]
deriveFoldable ty = do
(instanceType, cs) <- reifyConstructors ''Rank2.Foldable ty
(constraints, dec) <- genFoldMap instanceType cs
sequence [instanceD (TH.cxt $ map pure constraints) instanceType
[pure dec, pragInlD 'Rank2.foldMap Inlinable FunLike AllPhases]]
deriveTraversable :: Name -> Q [Dec]
deriveTraversable ty = do
(instanceType, cs) <- reifyConstructors ''Rank2.Traversable ty
(constraints, dec) <- genTraverse instanceType cs
sequence [instanceD (TH.cxt $ map pure constraints) instanceType
[pure dec, pragInlD 'Rank2.traverse Inlinable FunLike AllPhases]]
deriveDistributive :: Name -> Q [Dec]
deriveDistributive ty = do
(instanceType, cs) <- reifyConstructors ''Rank2.Distributive ty
(constraints, dec) <- genCotraverse cs
sequence [instanceD (TH.cxt $ map pure constraints) instanceType
[pure dec, pragInlD 'Rank2.cotraverse Inline FunLike AllPhases]]
deriveDistributiveTraversable :: Name -> Q [Dec]
deriveDistributiveTraversable ty = do
(instanceType, cs) <- reifyConstructors ''Rank2.DistributiveTraversable ty
(constraints, dec) <- genCotraverseTraversable cs
sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec]]
deriveLogistic :: Name -> Q [Dec]
deriveLogistic ty = do
(instanceType, cs) <- reifyConstructors ''Rank2.Logistic ty
(constraints, decs) <- genDeliver instanceType cs
sequence [instanceD (TH.cxt $ map pure constraints) instanceType
(map pure decs <> [pragInlD 'Rank2.deliver Inline FunLike AllPhases])]
reifyConstructors :: Name -> Name -> Q (TypeQ, [Con])
reifyConstructors cls ty = do
(TyConI tyCon) <- TH.reify ty
(tyConName, tyVars, _kind, cs) <- case tyCon of
DataD _ nm tyVars kind cs _ -> return (nm, tyVars, kind, cs)
NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c])
_ -> fail "deriveApply: tyCon may not be a type synonym."
let reifySynonyms (ConT name) = TH.reify name >>= reifySynonymInfo name
reifySynonyms (AppT t1 t2) = AppT <$> reifySynonyms t1 <*> reifySynonyms t2
reifySynonyms t = pure t
reifySynonymInfo _ (TyConI (TySynD _ [] t)) = reifySynonyms t
reifySynonymInfo name _ = pure (ConT name)
#if MIN_VERSION_template_haskell(2,17,0)
reifyTVKindSynonyms (KindedTV v s k) = KindedTV v s <$> reifySynonyms k
#else
reifyTVKindSynonyms (KindedTV v k) = KindedTV v <$> reifySynonyms k
#endif
reifyTVKindSynonyms tv = pure tv
lastVar <- reifyTVKindSynonyms (last tyVars)
#if MIN_VERSION_template_haskell(2,17,0)
let (KindedTV tyVar _ (AppT (AppT ArrowT _) resultKind)) = lastVar
instanceType = conT cls `TH.appT` foldl apply (conT tyConName) (init tyVars)
apply t (PlainTV name _) = TH.appT t (varT name)
apply t (KindedTV name _ _) = TH.appT t (varT name)
#else
let (KindedTV tyVar (AppT (AppT ArrowT _) resultKind)) = lastVar
instanceType = conT cls `TH.appT` foldl apply (conT tyConName) (init tyVars)
apply t (PlainTV name) = TH.appT t (varT name)
apply t (KindedTV name _) = TH.appT t (varT name)
#endif
case resultKind of
StarT -> pure ()
_ -> fail ("Unexpected result kind: " <> show resultKind)
putQ (Deriving tyConName tyVar)
return (instanceType, cs)
genFmap :: TypeQ -> [Con] -> Q ([Type], Dec)
genFmap instanceType cs = do
it <- instanceType
(constraints, clauses) <- unzip <$> mapM (genFmapClause it) cs
return (concat constraints, FunD '(Rank2.<$>) clauses)
genAp :: TypeQ -> [Con] -> Q ([Type], Dec)
genAp instanceType [con] = do
it <- instanceType
(constraints, clause) <- genApClause False it con
return (constraints, FunD '(Rank2.<*>) [clause])
genLiftA2 :: [Con] -> Q Dec
genLiftA2 [con] = TH.funD 'Rank2.liftA2 [genLiftA2Clause False con]
genLiftA3 :: [Con] -> Q Dec
genLiftA3 [con] = TH.funD 'Rank2.liftA3 [genLiftA3Clause False con]
genApUnsafely :: TypeQ -> [Con] -> Q ([Type], Dec)
genApUnsafely instanceType cons = do
it <- instanceType
(constraints, clauses) <- unzip <$> mapM (genApClause True it) cons
return (concat constraints, FunD '(Rank2.<*>) clauses)
genLiftA2Unsafely :: [Con] -> Q Dec
genLiftA2Unsafely cons = TH.funD 'Rank2.liftA2 (genLiftA2Clause True <$> cons)
genLiftA3Unsafely :: [Con] -> Q Dec
genLiftA3Unsafely cons = TH.funD 'Rank2.liftA3 (genLiftA3Clause True <$> cons)
genPure :: [Con] -> Q ([Type], Dec)
genPure cs = do (constraints, clauses) <- unzip <$> mapM genPureClause cs
return (concat constraints, FunD 'Rank2.pure clauses)
genFoldMap :: TypeQ -> [Con] -> Q ([Type], Dec)
genFoldMap instanceType cs = do
it <- instanceType
(constraints, clauses) <- unzip <$> mapM (genFoldMapClause it) cs
return (concat constraints, FunD 'Rank2.foldMap clauses)
genTraverse :: TypeQ -> [Con] -> Q ([Type], Dec)
genTraverse instanceType cs = do
it <- instanceType
(constraints, clauses) <- unzip <$> mapM (genTraverseClause it) cs
return (concat constraints, FunD 'Rank2.traverse clauses)
genCotraverse :: [Con] -> Q ([Type], Dec)
genCotraverse [con] = do (constraints, clause) <- genCotraverseClause con
return (constraints, FunD 'Rank2.cotraverse [clause])
genCotraverseTraversable :: [Con] -> Q ([Type], Dec)
genCotraverseTraversable [con] = do (constraints, clause) <- genCotraverseTraversableClause con
return (constraints, FunD 'Rank2.cotraverseTraversable [clause])
genDeliver :: TypeQ -> [Con] -> Q ([Type], [Dec])
genDeliver instanceType [con] = do
it <- instanceType
let AppT _classType rt = it
recType = pure rt
signable <- TH.isExtEnabled TH.InstanceSigs
scopable <- TH.isExtEnabled TH.ScopedTypeVariables
if signable && scopable then do
p <- newName "p"
q <- newName "q"
(constraints, clause) <- genDeliverClause recType (Just q) con
ctx <- [t| Contravariant $(varT p) |]
methodType <- [t| $(varT p) ($(recType) $(varT q) -> $(recType) $(varT q)) -> $(recType) (Compose $(varT p) ($(varT q) Rank2.~> $(varT q))) |]
return (constraints,
[SigD 'Rank2.deliver (ForallT [binder p, binder q] [ctx] methodType),
FunD 'Rank2.deliver [clause]])
else do
(constraints, clause) <- genDeliverClause recType Nothing con
return (constraints, [FunD 'Rank2.deliver [clause]])
genFmapClause :: Type -> Con -> Q ([Type], Clause)
genFmapClause _ (NormalC name fieldTypes) = do
f <- newName "f"
fieldNames <- replicateM (length fieldTypes) (newName "x")
let pats = [varP f, conP name (map varP fieldNames)]
constraintsAndFields = zipWith newField fieldNames fieldTypes
newFields = map (snd <$>) constraintsAndFields
body = normalB $ TH.appsE $ conE name : newFields
newField :: Name -> BangType -> Q ([Type], Exp)
newField x (_, fieldType) = genFmapField (varE f) fieldType (varE x) id
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause pats body []
genFmapClause _ (RecC name fields) = do
f <- newName "f"
x <- newName "x"
let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields
constraintsAndFields = map newNamedField fields
newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (fieldName, _, fieldType) =
((,) fieldName <$>)
<$> genFmapField (varE f) fieldType (getFieldOf x fieldName) id
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] body []
genFmapClause instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
let AppT _classType t = instanceType
first (renameConstraintVars t initType <$>) <$> genFmapClause instanceType (NormalC name fieldTypes)
genFmapClause instanceType (RecGadtC [name] fields _resultType@(AppT initType (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
let AppT _classType t = instanceType
first (renameConstraintVars t initType <$>) <$> genFmapClause instanceType (RecC name fields)
genFmapClause instanceType (ForallC _vars _cxt con) = genFmapClause instanceType con
genFmapField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField fun fieldType fieldAccess wrap = do
Just (Deriving _ typeVar) <- getQ
case fieldType of
AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap fun) fieldAccess
AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain ''Rank2.Functor t1) <$> appE (wrap [| ($fun Rank2.<$>) |]) fieldAccess
AppT t1 t2 | t1 /= VarT typeVar -> genFmapField fun t2 fieldAccess (wrap . appE (varE '(<$>)))
SigT ty _kind -> genFmapField fun ty fieldAccess wrap
ParensT ty -> genFmapField fun ty fieldAccess wrap
_ -> (,) [] <$> fieldAccess
genLiftA2Clause :: Bool -> Con -> Q Clause
genLiftA2Clause unsafely (NormalC name fieldTypes) = do
f <- newName "f"
fieldNames1 <- replicateM (length fieldTypes) (newName "x")
y <- newName "y"
fieldNames2 <- replicateM (length fieldTypes) (newName "y")
let pats = [varP f, conP name (map varP fieldNames1), varP y]
body = normalB $ TH.appsE $ conE name : zipWith newField (zip fieldNames1 fieldNames2) fieldTypes
newField :: (Name, Name) -> BangType -> Q Exp
newField (x, y) (_, fieldType) = genLiftA2Field unsafely (varE f) fieldType (varE x) (varE y) id
TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE y) []]
genLiftA2Clause unsafely (RecC name fields) = do
f <- newName "f"
x <- newName "x"
y <- newName "y"
let body = normalB $ recConE name $ map newNamedField fields
newNamedField :: VarBangType -> Q (Name, Exp)
newNamedField (fieldName, _, fieldType) =
TH.fieldExp fieldName $
genLiftA2Field unsafely (varE f) fieldType (getFieldOf x fieldName) (getFieldOf y fieldName) id
TH.clause [varP f, x `TH.asP` TH.recP name [], varP y] body []
genLiftA2Clause unsafely (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
genLiftA2Clause unsafely (NormalC name fieldTypes)
genLiftA2Clause unsafely (RecGadtC [name] fields _resultType@(AppT _ (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
genLiftA2Clause unsafely (RecC name fields)
genLiftA2Clause unsafely (ForallC _vars _cxt con) = genLiftA2Clause unsafely con
genLiftA2Field :: Bool -> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field unsafely fun fieldType field1Access field2Access wrap = do
Just (Deriving _ typeVar) <- getQ
case fieldType of
AppT ty _ | ty == VarT typeVar -> [| $(wrap fun) $field1Access $field2Access |]
AppT _ ty | ty == VarT typeVar -> [| $(wrap $ appE (varE 'Rank2.liftA2) fun) $field1Access $field2Access |]
AppT t1 t2
| t1 /= VarT typeVar -> genLiftA2Field unsafely fun t2 field1Access field2Access (appE (varE 'liftA2) . wrap)
SigT ty _kind -> genLiftA2Field unsafely fun ty field1Access field2Access wrap
ParensT ty -> genLiftA2Field unsafely fun ty field1Access field2Access wrap
_ | unsafely -> field1Access
| otherwise -> error ("Cannot apply liftA2 to field of type " <> show fieldType)
genLiftA3Clause :: Bool -> Con -> Q Clause
genLiftA3Clause unsafely (NormalC name fieldTypes) = do
f <- newName "f"
fieldNames1 <- replicateM (length fieldTypes) (newName "x")
y <- newName "y"
z <- newName "z"
fieldNames2 <- replicateM (length fieldTypes) (newName "y")
fieldNames3 <- replicateM (length fieldTypes) (newName "z")
let pats = [varP f, conP name (map varP fieldNames1), varP y, varP z]
body = normalB $ TH.appsE $ conE name : zipWith newField (zip3 fieldNames1 fieldNames2 fieldNames3) fieldTypes
newField :: (Name, Name, Name) -> BangType -> Q Exp
newField (x, y, z) (_, fieldType) = genLiftA3Field unsafely (varE f) fieldType (varE x) (varE y) (varE z) id
TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE y) [],
TH.valD (conP name $ map varP fieldNames3) (normalB $ varE z) []]
genLiftA3Clause unsafely (RecC name fields) = do
f <- newName "f"
x <- newName "x"
y <- newName "y"
z <- newName "z"
let body = normalB $ recConE name $ map newNamedField fields
newNamedField :: VarBangType -> Q (Name, Exp)
newNamedField (fieldName, _, fieldType) =
TH.fieldExp fieldName
(genLiftA3Field unsafely (varE f) fieldType (getFieldOf x fieldName) (getFieldOf y fieldName) (getFieldOf z fieldName) id)
TH.clause [varP f, x `TH.asP` TH.recP name [], varP y, varP z] body []
genLiftA3Clause unsafely (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
genLiftA3Clause unsafely (NormalC name fieldTypes)
genLiftA3Clause unsafely (RecGadtC [name] fields _resultType@(AppT _ (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
genLiftA3Clause unsafely (RecC name fields)
genLiftA3Clause unsafely (ForallC _vars _cxt con) = genLiftA3Clause unsafely con
genLiftA3Field :: Bool -> Q Exp -> Type -> Q Exp -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA3Field unsafely fun fieldType field1Access field2Access field3Access wrap = do
Just (Deriving _ typeVar) <- getQ
case fieldType of
AppT ty _
| ty == VarT typeVar -> [| $(wrap fun) $(field1Access) $(field2Access) $(field3Access) |]
AppT _ ty
| ty == VarT typeVar -> [| $(wrap $ appE (varE 'Rank2.liftA3) fun) $(field1Access) $(field2Access) $(field3Access) |]
AppT t1 t2
| t1 /= VarT typeVar
-> genLiftA3Field unsafely fun t2 field1Access field2Access field3Access (appE (varE 'liftA3) . wrap)
SigT ty _kind -> genLiftA3Field unsafely fun ty field1Access field2Access field3Access wrap
ParensT ty -> genLiftA3Field unsafely fun ty field1Access field2Access field3Access wrap
_ | unsafely -> field1Access
| otherwise -> error ("Cannot apply liftA3 to field of type " <> show fieldType)
genApClause :: Bool -> Type -> Con -> Q ([Type], Clause)
genApClause unsafely _ (NormalC name fieldTypes) = do
fieldNames1 <- replicateM (length fieldTypes) (newName "x")
fieldNames2 <- replicateM (length fieldTypes) (newName "y")
rhsName <- newName "rhs"
let pats = [conP name (map varP fieldNames1), varP rhsName]
constraintsAndFields = zipWith newField (zip fieldNames1 fieldNames2) fieldTypes
newFields = map (snd <$>) constraintsAndFields
body = normalB $ TH.appsE $ conE name : newFields
newField :: (Name, Name) -> BangType -> Q ([Type], Exp)
newField (x, y) (_, fieldType) = genApField unsafely fieldType (varE x) (varE y) id
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE rhsName) []]
genApClause unsafely _ (RecC name fields) = do
x <- newName "x"
y <- newName "y"
let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields
constraintsAndFields = map newNamedField fields
newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (fieldName, _, fieldType) =
((,) fieldName <$>) <$> genApField unsafely fieldType (getFieldOf x fieldName) (getFieldOf y fieldName) id
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause [x `TH.asP` TH.recP name [], varP y] body []
genApClause unsafely instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
let AppT _classType t = instanceType
first (renameConstraintVars t initType <$>) <$> genApClause unsafely instanceType (NormalC name fieldTypes)
genApClause unsafely instanceType (RecGadtC [name] fields _resultType@(AppT initType (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
let AppT _classType t = instanceType
first (renameConstraintVars t initType <$>) <$> genApClause unsafely instanceType (RecC name fields)
genApClause unsafely instanceType (ForallC _vars _cxt con) = genApClause unsafely instanceType con
genApField :: Bool -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField unsafely fieldType field1Access field2Access wrap = do
Just (Deriving _ typeVar) <- getQ
case fieldType of
AppT ty _ | ty == VarT typeVar -> (,) [] <$> [| $(wrap (varE 'Rank2.apply)) $(field1Access) $(field2Access) |]
AppT t1 t2 | t2 == VarT typeVar ->
(,) (constrain ''Rank2.Apply t1) <$> [| $(wrap (varE 'Rank2.ap)) $(field1Access) $(field2Access) |]
AppT t1 t2 | t1 /= VarT typeVar -> genApField unsafely t2 field1Access field2Access (appE (varE 'liftA2) . wrap)
SigT ty _kind -> genApField unsafely ty field1Access field2Access wrap
ParensT ty -> genApField unsafely ty field1Access field2Access wrap
_ | unsafely -> (,) [] <$> field1Access
| otherwise -> error ("Cannot apply ap to field of type " <> show fieldType)
genPureClause :: Con -> Q ([Type], Clause)
genPureClause (NormalC name fieldTypes) = do
argName <- newName "f"
let body = normalB $ TH.appsE $ conE name : ((snd <$>) <$> constraintsAndFields)
constraintsAndFields = map newField fieldTypes
newField :: BangType -> Q ([Type], Exp)
newField (_, fieldType) = genPureField fieldType (varE argName) id
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause [varP argName] body []
genPureClause (RecC name fields) = do
argName <- newName "f"
let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields
constraintsAndFields = map newNamedField fields
newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> genPureField fieldType (varE argName) id
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause [varP argName] body []
genPureField :: Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField fieldType pureValue wrap = do
Just (Deriving _ typeVar) <- getQ
case fieldType of
AppT ty _ | ty == VarT typeVar -> (,) [] <$> wrap pureValue
AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain ''Rank2.Applicative t1) <$> wrap (appE (varE 'Rank2.pure) pureValue)
AppT t1 t2 | t1 /= VarT typeVar -> genPureField t2 pureValue (wrap . appE (varE 'pure))
SigT ty _kind -> genPureField ty pureValue wrap
ParensT ty -> genPureField ty pureValue wrap
_ -> error ("Cannot create a pure field of type " <> show fieldType)
genFoldMapClause :: Type -> Con -> Q ([Type], Clause)
genFoldMapClause _ (NormalC name fieldTypes) = do
f <- newName "f"
fieldNames <- replicateM (length fieldTypes) (newName "x")
let pats = [varP f, conP name (map varP fieldNames)]
constraintsAndFields = zipWith newField fieldNames fieldTypes
body | null fieldNames = [| mempty |]
| otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields
append a b = [| $(a) <> $(b) |]
newField :: Name -> BangType -> Q ([Type], Exp)
newField x (_, fieldType) = genFoldMapField f fieldType (varE x) id
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause pats (normalB body) []
genFoldMapClause _ (RecC name fields) = do
f <- newName "f"
x <- newName "x"
let body | null fields = [| mempty |]
| otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields
constraintsAndFields = map newField fields
append a b = [| $(a) <> $(b) |]
newField :: VarBangType -> Q ([Type], Exp)
newField (fieldName, _, fieldType) = genFoldMapField f fieldType (getFieldOf x fieldName) id
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] (normalB body) []
genFoldMapClause instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
let AppT _classType t = instanceType
first (renameConstraintVars t initType <$>) <$> genFoldMapClause instanceType (NormalC name fieldTypes)
genFoldMapClause instanceType (RecGadtC [name] fields _resultType@(AppT initType (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
let AppT _classType t = instanceType
first (renameConstraintVars t initType <$>) <$> genFoldMapClause instanceType (RecC name fields)
genFoldMapClause instanceType (ForallC _vars _cxt con) = genFoldMapClause instanceType con
genFoldMapField :: Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField funcName fieldType fieldAccess wrap = do
Just (Deriving _ typeVar) <- getQ
case fieldType of
AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap $ varE funcName) fieldAccess
AppT t1 t2 | t2 == VarT typeVar ->
(,) (constrain ''Rank2.Foldable t1) <$> appE (wrap $ appE (varE 'Rank2.foldMap) (varE funcName)) fieldAccess
AppT t1 t2 | t1 /= VarT typeVar -> genFoldMapField funcName t2 fieldAccess (wrap . appE (varE 'foldMap))
SigT ty _kind -> genFoldMapField funcName ty fieldAccess wrap
ParensT ty -> genFoldMapField funcName ty fieldAccess wrap
_ -> (,) [] <$> [| mempty |]
genTraverseClause :: Type -> Con -> Q ([Type], Clause)
genTraverseClause _ (NormalC name []) =
(,) [] <$> TH.clause [wildP, conP name []] (normalB [| pure $(conE name) |]) []
genTraverseClause _ (NormalC name fieldTypes) = do
f <- newName "f"
fieldNames <- replicateM (length fieldTypes) (newName "x")
let pats = [varP f, conP name (map varP fieldNames)]
constraintsAndFields = zipWith newField fieldNames fieldTypes
newFields = map (snd <$>) constraintsAndFields
body = normalB $ fst $ foldl apply (conE name, False) newFields
apply (a, False) b = ([| $(a) <$> $(b) |], True)
apply (a, True) b = ([| $(a) <*> $(b) |], True)
newField :: Name -> BangType -> Q ([Type], Exp)
newField x (_, fieldType) = genTraverseField (varE f) fieldType (varE x) id
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause pats body []
genTraverseClause _ (RecC name fields) = do
f <- newName "f"
x <- newName "x"
let constraintsAndFields = map newField fields
body = normalB $ fst $ foldl apply (conE name, False) $ (snd <$>) <$> constraintsAndFields
apply (a, False) b = ([| $(a) <$> $(b) |], True)
apply (a, True) b = ([| $(a) <*> $(b) |], True)
newField :: VarBangType -> Q ([Type], Exp)
newField (fieldName, _, fieldType) = genTraverseField (varE f) fieldType (getFieldOf x fieldName) id
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] body []
genTraverseClause instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
let AppT _classType t = instanceType
first (renameConstraintVars t initType <$>) <$> genTraverseClause instanceType (NormalC name fieldTypes)
genTraverseClause instanceType (RecGadtC [name] fields _resultType@(AppT initType (VarT tyVar))) =
do Just (Deriving tyConName _tyVar) <- getQ
putQ (Deriving tyConName tyVar)
let AppT _classType t = instanceType
first (renameConstraintVars t initType <$>) <$> genTraverseClause instanceType (RecC name fields)
genTraverseClause instanceType (ForallC _vars _cxt con) = genTraverseClause instanceType con
genTraverseField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField fun fieldType fieldAccess wrap = do
Just (Deriving _ typeVar) <- getQ
case fieldType of
AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap fun) fieldAccess
AppT t1 t2 | t2 == VarT typeVar ->
(,) (constrain ''Rank2.Traversable t1) <$> appE (wrap [| Rank2.traverse $fun |]) fieldAccess
AppT t1 t2 | t1 /= VarT typeVar -> genTraverseField fun t2 fieldAccess (wrap . appE (varE 'traverse))
SigT ty _kind -> genTraverseField fun ty fieldAccess wrap
ParensT ty -> genTraverseField fun ty fieldAccess wrap
_ -> (,) [] <$> [| pure $fieldAccess |]
genCotraverseClause :: Con -> Q ([Type], Clause)
genCotraverseClause (NormalC name []) = genCotraverseClause (RecC name [])
genCotraverseClause (RecC name fields) = do
withName <- newName "w"
argName <- newName "f"
let constraintsAndFields = map newNamedField fields
body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields
newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (fieldName, _, fieldType) =
((,) fieldName <$>) <$> (genCotraverseField ''Rank2.Distributive (varE 'Rank2.cotraverse) (varE withName)
fieldType [| $(projectField fieldName) <$> $(varE argName) |] id)
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause [varP withName, varP argName] body []
genCotraverseTraversableClause :: Con -> Q ([Type], Clause)
genCotraverseTraversableClause (NormalC name []) = genCotraverseTraversableClause (RecC name [])
genCotraverseTraversableClause (RecC name fields) = do
withName <- newName "w"
argName <- newName "f"
let constraintsAndFields = map newNamedField fields
body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields
newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (fieldName, _, fieldType) =
((,) fieldName <$>) <$> (genCotraverseField ''Rank2.DistributiveTraversable
(varE 'Rank2.cotraverseTraversable) (varE withName) fieldType
[| $(projectField fieldName) <$> $(varE argName) |] id)
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause [varP withName, varP argName] body []
genDeliverClause :: TypeQ -> Maybe Name -> Con -> Q ([Type], Clause)
genDeliverClause recType typeVar (NormalC name []) = genDeliverClause recType typeVar (RecC name [])
genDeliverClause recType typeVar (RecC name fields) = do
argName <- newName "f"
let constraintsAndFields = map newNamedField fields
body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields
recExp g = maybe g (\v-> [|($g :: $(recType) $(varT v))|]) typeVar
newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (fieldName, _, fieldType) =
((,) fieldName <$>)
<$> (genDeliverField ''Rank2.Logistic fieldType
(\wrap-> [| \set g-> $(TH.recUpdE (recExp [|g|]) [(,) fieldName <$> appE (wrap [| Rank2.apply set |]) (getFieldOfE [|g|] fieldName)]) |])
(\wrap-> [| \set g-> $(TH.recUpdE (recExp [|g|]) [(,) fieldName <$> appE (wrap [| set |]) (getFieldOfE [|g|] fieldName)]) |])
(varE argName)
id
id)
constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
(,) constraints <$> TH.clause [varP argName] body []
genCotraverseField :: Name -> Q Exp -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genCotraverseField className method fun fieldType fieldAccess wrap = do
Just (Deriving _ typeVar) <- getQ
case fieldType of
AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap fun) fieldAccess
AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain className t1) <$> appE (wrap $ appE method fun) fieldAccess
AppT t1 t2 | t1 /= VarT typeVar ->
genCotraverseField className method fun t2 fieldAccess (wrap . appE (varE 'cotraverse))
SigT ty _kind -> genCotraverseField className method fun ty fieldAccess wrap
ParensT ty -> genCotraverseField className method fun ty fieldAccess wrap
genDeliverField :: Name
-> Type
-> ((Q Exp -> Q Exp) -> Q Exp)
-> ((Q Exp -> Q Exp) -> Q Exp)
-> Q Exp
-> (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genDeliverField className fieldType fieldUpdate subRecordUpdate arg outer inner = do
Just (Deriving _ typeVar) <- getQ
case fieldType of
AppT ty _ | ty == VarT typeVar -> (,) [] <$> outer (appE [|Compose|] ([|contramap|] `appE` fieldUpdate inner `appE` arg))
AppT t1 t2 | t2 == VarT typeVar ->
(,) (constrain className t1) <$> outer (appE [| Rank2.deliver |] ([|contramap|] `appE` subRecordUpdate inner `appE` arg))
AppT t1 t2 | t1 /= VarT typeVar ->
genDeliverField className t2 fieldUpdate subRecordUpdate arg (outer . appE (varE 'pure)) (inner . appE (varE 'fmap))
SigT ty _kind -> genDeliverField className ty fieldUpdate subRecordUpdate arg outer inner
ParensT ty -> genDeliverField className ty fieldUpdate subRecordUpdate arg outer inner
renameConstraintVars :: Type -> Type -> Type -> Type
renameConstraintVars (AppT instanceType (VarT instanceVar)) (AppT returnType (VarT returnVar)) constrainedType =
renameConstraintVars instanceType returnType (renameConstraintVar returnVar instanceVar constrainedType)
renameConstraintVars (AppT instanceType _) (AppT returnType _) constrainedType =
renameConstraintVars instanceType returnType constrainedType
renameConstraintVars _ _ constrainedType = constrainedType
renameConstraintVar :: Name -> Name -> Type -> Type
renameConstraintVar from to (VarT name)
| name == from = VarT to
| otherwise = VarT name
renameConstraintVar from to (AppT a b) = AppT (renameConstraintVar from to a) (renameConstraintVar from to b)
#if MIN_VERSION_template_haskell(2,15,0)
renameConstraintVar from to (AppKindT t k) = AppT (renameConstraintVar from to t) (renameConstraintVar from to k)
#endif
renameConstraintVar from to (InfixT a op b) = InfixT (renameConstraintVar from to a) op (renameConstraintVar from to b)
renameConstraintVar from to (UInfixT a op b) = UInfixT (renameConstraintVar from to a) op (renameConstraintVar from to b)
renameConstraintVar from to (SigT t k) = SigT (renameConstraintVar from to t) (renameConstraintVar from to k)
renameConstraintVar from to (ParensT t) = ParensT (renameConstraintVar from to t)
renameConstraintVar _ _ t = t
projectField :: Name -> Q Exp
projectField field = do
#if MIN_VERSION_template_haskell(2,19,0)
dotty <- TH.isExtEnabled TH.OverloadedRecordDot
if dotty
then TH.projectionE (pure $ TH.nameBase field)
else varE field
#else
varE field
#endif
getFieldOf :: Name -> Name -> Q Exp
getFieldOf = getFieldOfE . varE
getFieldOfE :: Q Exp -> Name -> Q Exp
getFieldOfE record field = do
#if MIN_VERSION_template_haskell(2,19,0)
dotty <- TH.isExtEnabled TH.OverloadedRecordDot
if dotty
then TH.getFieldE record (TH.nameBase field)
else appE (varE field) record
#else
appE (varE field) record
#endif
constrain :: Name -> Type -> [Type]
constrain _ ConT{} = []
constrain cls t = [ConT cls `AppT` t]
#if MIN_VERSION_template_haskell(2,17,0)
binder :: Name -> TyVarBndr TH.Specificity
binder name = TH.PlainTV name TH.SpecifiedSpec
#else
binder :: Name -> TyVarBndr
binder = TH.PlainTV
#endif