{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Singletons.Deriving.Util where
import Control.Monad
import qualified Data.List as List
import Data.Singletons.Names
import Data.Singletons.Syntax
import Data.Singletons.Util
import Language.Haskell.TH.Desugar
import qualified Language.Haskell.TH.Desugar.OSet as OSet
import Language.Haskell.TH.Syntax
type DerivDesc q
= Maybe DCxt
-> DType
-> DataDecl
-> q UInstDecl
isNonVanillaDataType :: forall q. DsMonad q => DType -> [DCon] -> q Bool
isNonVanillaDataType :: DType -> [DCon] -> q Bool
isNonVanillaDataType DType
data_ty = (DCon -> q Bool) -> [DCon] -> q Bool
forall a. (a -> q Bool) -> [a] -> q Bool
anyM ((DCon -> q Bool) -> [DCon] -> q Bool)
-> (DCon -> q Bool) -> [DCon] -> q Bool
forall a b. (a -> b) -> a -> b
$ \con :: DCon
con@(DCon [DTyVarBndr]
_ DCxt
ctxt Name
_ DConFields
_ DType
_) -> do
[DTyVarBndr]
ex_tvbs <- DType -> DCon -> q [DTyVarBndr]
forall (q :: * -> *). DsMonad q => DType -> DCon -> q [DTyVarBndr]
conExistentialTvbs DType
data_ty DCon
con
Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> q Bool) -> Bool -> q Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [DTyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DTyVarBndr]
ex_tvbs Bool -> Bool -> Bool
&& DCxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null DCxt
ctxt
where
anyM :: (a -> q Bool) -> [a] -> q Bool
anyM :: (a -> q Bool) -> [a] -> q Bool
anyM a -> q Bool
_ [] = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
anyM a -> q Bool
p (a
x:[a]
xs) = do
Bool
b <- a -> q Bool
p a
x
if Bool
b then Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else (a -> q Bool) -> [a] -> q Bool
forall a. (a -> q Bool) -> [a] -> q Bool
anyM a -> q Bool
p [a]
xs
data FFoldType a
= FT { FFoldType a -> a
ft_triv :: a
, FFoldType a -> a
ft_var :: a
, FFoldType a -> DType -> a -> a
ft_ty_app :: DType -> a -> a
, FFoldType a -> a
ft_bad_app :: a
, FFoldType a -> [DTyVarBndr] -> a -> a
ft_forall :: [DTyVarBndr] -> a -> a
}
functorLikeTraverse :: forall q a.
DsMonad q
=> Name
-> FFoldType a
-> DType
-> q a
functorLikeTraverse :: Name -> FFoldType a -> DType -> q a
functorLikeTraverse Name
var (FT { ft_triv :: forall a. FFoldType a -> a
ft_triv = a
caseTrivial, ft_var :: forall a. FFoldType a -> a
ft_var = a
caseVar
, ft_ty_app :: forall a. FFoldType a -> DType -> a -> a
ft_ty_app = DType -> a -> a
caseTyApp, ft_bad_app :: forall a. FFoldType a -> a
ft_bad_app = a
caseWrongArg
, ft_forall :: forall a. FFoldType a -> [DTyVarBndr] -> a -> a
ft_forall = [DTyVarBndr] -> a -> a
caseForAll })
DType
ty
= do DType
ty' <- DType -> q DType
forall (q :: * -> *). DsMonad q => DType -> q DType
expandType DType
ty
(a
res, Bool
_) <- DType -> q (a, Bool)
go DType
ty'
a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
where
go :: DType
-> q (a, Bool)
go :: DType -> q (a, Bool)
go t :: DType
t@DAppT{} = do
let (DType
f, [DTypeArg]
args) = DType -> (DType, [DTypeArg])
unfoldDType DType
t
vis_args :: DCxt
vis_args = [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
args
(a
_, Bool
fc) <- DType -> q (a, Bool)
go DType
f
([a]
xrs, [Bool]
xcs) <- (DType -> q (a, Bool)) -> DCxt -> q ([a], [Bool])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM DType -> q (a, Bool)
go DCxt
vis_args
let wrongArg :: q (a, Bool)
wrongArg :: q (a, Bool)
wrongArg = (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseWrongArg, Bool
True)
if | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xcs)
-> q (a, Bool)
trivial
| Bool
fc Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> [Bool]
forall a. [a] -> [a]
init [Bool]
xcs)
-> q (a, Bool)
wrongArg
| Bool
otherwise
-> do Bool
itf <- Name -> DType -> DCxt -> q Bool
forall (q :: * -> *). DsMonad q => Name -> DType -> DCxt -> q Bool
isInTypeFamilyApp Name
var DType
f DCxt
vis_args
if Bool
itf
then q (a, Bool)
wrongArg
else (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DType -> a -> a
caseTyApp (DCxt -> DType
forall a. [a] -> a
last DCxt
vis_args) ([a] -> a
forall a. [a] -> a
last [a]
xrs), Bool
True)
go (DAppKindT DType
t DType
k) = do
(a
_, Bool
kc) <- DType -> q (a, Bool)
go DType
k
if Bool
kc
then (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseWrongArg, Bool
True)
else DType -> q (a, Bool)
go DType
t
go (DSigT DType
t DType
k) = do
(a
_, Bool
kc) <- DType -> q (a, Bool)
go DType
k
if Bool
kc
then (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseWrongArg, Bool
True)
else DType -> q (a, Bool)
go DType
t
go (DVarT Name
v)
| Name
v Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var = (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseVar, Bool
True)
| Bool
otherwise = q (a, Bool)
trivial
go (DForallT ForallVisFlag
_ [DTyVarBndr]
tvbs DType
t) = do
(a
tr, Bool
tc) <- DType -> q (a, Bool)
go DType
t
if Name
var Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndr -> Name
extractTvbName [DTyVarBndr]
tvbs Bool -> Bool -> Bool
&& Bool
tc
then (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DTyVarBndr] -> a -> a
caseForAll [DTyVarBndr]
tvbs a
tr, Bool
True)
else q (a, Bool)
trivial
go (DConstrainedT DCxt
_ DType
t) = DType -> q (a, Bool)
go DType
t
go (DConT {}) = q (a, Bool)
trivial
go DType
DArrowT = q (a, Bool)
trivial
go (DLitT {}) = q (a, Bool)
trivial
go DType
DWildCardT = q (a, Bool)
trivial
trivial :: q (a, Bool)
trivial :: q (a, Bool)
trivial = (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseTrivial, Bool
False)
isInTypeFamilyApp :: forall q. DsMonad q => Name -> DType -> [DType] -> q Bool
isInTypeFamilyApp :: Name -> DType -> DCxt -> q Bool
isInTypeFamilyApp Name
name DType
tyFun DCxt
tyArgs =
case DType
tyFun of
DConT Name
tcName -> Name -> q Bool
go Name
tcName
DType
_ -> Bool -> q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
where
go :: Name -> q Bool
go :: Name -> q Bool
go Name
tcName = do
Maybe DInfo
info <- Name -> q (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
tcName
case Maybe DInfo
info of
Just (DTyConI DDec
dec Maybe [DDec]
_)
| DOpenTypeFamilyD (DTypeFamilyHead Name
_ [DTyVarBndr]
bndrs DFamilyResultSig
_ Maybe InjectivityAnn
_) <- DDec
dec
-> [DTyVarBndr] -> q Bool
forall a. [a] -> q Bool
withinFirstArgs [DTyVarBndr]
bndrs
| DClosedTypeFamilyD (DTypeFamilyHead Name
_ [DTyVarBndr]
bndrs DFamilyResultSig
_ Maybe InjectivityAnn
_) [DTySynEqn]
_ <- DDec
dec
-> [DTyVarBndr] -> q Bool
forall a. [a] -> q Bool
withinFirstArgs [DTyVarBndr]
bndrs
Maybe DInfo
_ -> Bool -> q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
withinFirstArgs :: [a] -> q Bool
withinFirstArgs :: [a] -> q Bool
withinFirstArgs [a]
bndrs =
let firstArgs :: DCxt
firstArgs = Int -> DCxt -> DCxt
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) DCxt
tyArgs
argFVs :: OSet Name
argFVs = (DType -> OSet Name) -> DCxt -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DType -> OSet Name
fvDType DCxt
firstArgs
in Bool -> q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> q Bool) -> Bool -> q Bool
forall a b. (a -> b) -> a -> b
$ Name
name Name -> OSet Name -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` OSet Name
argFVs
functorLikeValidityChecks :: forall q. DsMonad q => Bool -> DataDecl -> q ()
functorLikeValidityChecks :: Bool -> DataDecl -> q ()
functorLikeValidityChecks Bool
allowConstrainedLastTyVar (DataDecl Name
n [DTyVarBndr]
data_tvbs [DCon]
cons)
| [DTyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DTyVarBndr]
data_tvbs
= String -> q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ String
"Data type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must have some type parameters"
| Bool
otherwise
= (DCon -> q ()) -> [DCon] -> q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DCon -> q ()
check_con [DCon]
cons
where
check_con :: DCon -> q ()
check_con :: DCon -> q ()
check_con DCon
con = do
DCon -> q ()
check_universal DCon
con
[q ()]
checks <- FFoldType (q ()) -> DCon -> q [q ()]
forall (q :: * -> *) a. DsMonad q => FFoldType a -> DCon -> q [a]
foldDataConArgs (Name -> FFoldType (q ())
ft_check (DCon -> Name
extractName DCon
con)) DCon
con
[q ()] -> q ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [q ()]
checks
check_universal :: DCon -> q ()
check_universal :: DCon -> q ()
check_universal con :: DCon
con@(DCon [DTyVarBndr]
con_tvbs DCxt
con_theta Name
con_name DConFields
_ DType
res_ty)
| Bool
allowConstrainedLastTyVar
= () -> q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| (DType
_, [DTypeArg]
res_ty_args) <- DType -> (DType, [DTypeArg])
unfoldDType DType
res_ty
, (DCxt
_, DType
last_res_ty_arg) <- DCxt -> (DCxt, DType)
forall a. [a] -> ([a], a)
snocView (DCxt -> (DCxt, DType)) -> DCxt -> (DCxt, DType)
forall a b. (a -> b) -> a -> b
$ [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
res_ty_args
, Just Name
last_tv <- DType -> Maybe Name
getDVarTName_maybe DType
last_res_ty_arg
= do [DTyVarBndr]
ex_tvbs <- DType -> DCon -> q [DTyVarBndr]
forall (q :: * -> *). DsMonad q => DType -> DCon -> q [DTyVarBndr]
conExistentialTvbs (DType -> [DTyVarBndr] -> DType
foldTypeTvbs (Name -> DType
DConT Name
n) [DTyVarBndr]
data_tvbs) DCon
con
let univ_tvb_names :: [Name]
univ_tvb_names = (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndr -> Name
extractTvbName [DTyVarBndr]
con_tvbs [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
List.\\ (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndr -> Name
extractTvbName [DTyVarBndr]
ex_tvbs
if Name
last_tv Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
univ_tvb_names
Bool -> Bool -> Bool
&& Name
last_tv Name -> OSet Name -> Bool
forall a. Ord a => a -> OSet a -> Bool
`OSet.notMember` (DType -> OSet Name) -> DCxt -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DType -> OSet Name
fvDType DCxt
con_theta
then () -> q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else String -> q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ Name -> String -> String
badCon Name
con_name String
existential
| Bool
otherwise
= String -> q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ Name -> String -> String
badCon Name
con_name String
existential
ft_check :: Name -> FFoldType (q ())
ft_check :: Name -> FFoldType (q ())
ft_check Name
con_name =
FT :: forall a.
a
-> a
-> (DType -> a -> a)
-> a
-> ([DTyVarBndr] -> a -> a)
-> FFoldType a
FT { ft_triv :: q ()
ft_triv = () -> q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, ft_var :: q ()
ft_var = () -> q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, ft_ty_app :: DType -> q () -> q ()
ft_ty_app = \DType
_ q ()
x -> q ()
x
, ft_bad_app :: q ()
ft_bad_app = String -> q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ Name -> String -> String
badCon Name
con_name String
wrong_arg
, ft_forall :: [DTyVarBndr] -> q () -> q ()
ft_forall = \[DTyVarBndr]
_ q ()
x -> q ()
x
}
badCon :: Name -> String -> String
badCon :: Name -> String -> String
badCon Name
con_name String
msg = String
"Constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
con_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
existential, wrong_arg :: String
existential :: String
existential = String
"must be truly polymorphic in the last argument of the data type"
wrong_arg :: String
wrong_arg = String
"must use the type variable only as the last argument of a data type"
deepSubtypesContaining :: DsMonad q => Name -> DType -> q [DType]
deepSubtypesContaining :: Name -> DType -> q DCxt
deepSubtypesContaining Name
tv
= Name -> FFoldType DCxt -> DType -> q DCxt
forall (q :: * -> *) a.
DsMonad q =>
Name -> FFoldType a -> DType -> q a
functorLikeTraverse Name
tv
(FT :: forall a.
a
-> a
-> (DType -> a -> a)
-> a
-> ([DTyVarBndr] -> a -> a)
-> FFoldType a
FT { ft_triv :: DCxt
ft_triv = []
, ft_var :: DCxt
ft_var = []
, ft_ty_app :: DType -> DCxt -> DCxt
ft_ty_app = (:)
, ft_bad_app :: DCxt
ft_bad_app = String -> DCxt
forall a. HasCallStack => String -> a
error String
"in other argument in deepSubtypesContaining"
, ft_forall :: [DTyVarBndr] -> DCxt -> DCxt
ft_forall = \[DTyVarBndr]
tvbs DCxt
xs -> (DType -> Bool) -> DCxt -> DCxt
forall a. (a -> Bool) -> [a] -> [a]
filter (\DType
x -> (DTyVarBndr -> Bool) -> [DTyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (DType -> DTyVarBndr -> Bool
not_in_ty DType
x) [DTyVarBndr]
tvbs) DCxt
xs })
where
not_in_ty :: DType -> DTyVarBndr -> Bool
not_in_ty :: DType -> DTyVarBndr -> Bool
not_in_ty DType
ty DTyVarBndr
tvb = DTyVarBndr -> Name
extractTvbName DTyVarBndr
tvb Name -> OSet Name -> Bool
forall a. Ord a => a -> OSet a -> Bool
`OSet.notMember` DType -> OSet Name
fvDType DType
ty
foldDataConArgs :: forall q a. DsMonad q => FFoldType a -> DCon -> q [a]
foldDataConArgs :: FFoldType a -> DCon -> q [a]
foldDataConArgs FFoldType a
ft (DCon [DTyVarBndr]
_ DCxt
_ Name
_ DConFields
fields DType
res_ty) = do
DCxt
field_tys <- (DType -> q DType) -> DCxt -> q DCxt
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DType -> q DType
forall (q :: * -> *). DsMonad q => DType -> q DType
expandType (DCxt -> q DCxt) -> DCxt -> q DCxt
forall a b. (a -> b) -> a -> b
$ DConFields -> DCxt
tysOfConFields DConFields
fields
(DType -> q a) -> DCxt -> q [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DType -> q a
foldArg DCxt
field_tys
where
foldArg :: DType -> q a
foldArg :: DType -> q a
foldArg
| (DType
_, [DTypeArg]
res_ty_args) <- DType -> (DType, [DTypeArg])
unfoldDType DType
res_ty
, (DCxt
_, DType
last_res_ty_arg) <- DCxt -> (DCxt, DType)
forall a. [a] -> ([a], a)
snocView (DCxt -> (DCxt, DType)) -> DCxt -> (DCxt, DType)
forall a b. (a -> b) -> a -> b
$ [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
res_ty_args
, Just Name
last_tv <- DType -> Maybe Name
getDVarTName_maybe DType
last_res_ty_arg
= Name -> FFoldType a -> DType -> q a
forall (q :: * -> *) a.
DsMonad q =>
Name -> FFoldType a -> DType -> q a
functorLikeTraverse Name
last_tv FFoldType a
ft
| Bool
otherwise
= q a -> DType -> q a
forall a b. a -> b -> a
const (a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (FFoldType a -> a
forall a. FFoldType a -> a
ft_triv FFoldType a
ft))
getDVarTName_maybe :: DType -> Maybe Name
getDVarTName_maybe :: DType -> Maybe Name
getDVarTName_maybe (DSigT DType
t DType
_) = DType -> Maybe Name
getDVarTName_maybe DType
t
getDVarTName_maybe (DVarT Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
getDVarTName_maybe DType
_ = Maybe Name
forall a. Maybe a
Nothing
mkSimpleLam :: Quasi q => (DExp -> q DExp) -> q DExp
mkSimpleLam :: (DExp -> q DExp) -> q DExp
mkSimpleLam DExp -> q DExp
lam = do
Name
n <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"n"
DExp
body <- DExp -> q DExp
lam (Name -> DExp
DVarE Name
n)
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
n] DExp
body
mkSimpleLam2 :: Quasi q => (DExp -> DExp -> q DExp) -> q DExp
mkSimpleLam2 :: (DExp -> DExp -> q DExp) -> q DExp
mkSimpleLam2 DExp -> DExp -> q DExp
lam = do
Name
n1 <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"n1"
Name
n2 <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"n2"
DExp
body <- DExp -> DExp -> q DExp
lam (Name -> DExp
DVarE Name
n1) (Name -> DExp
DVarE Name
n2)
DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
n1, Name
n2] DExp
body
mkSimpleConClause :: Quasi q
=> (Name -> [DExp] -> DExp)
-> [DPat]
-> DCon
-> [DExp]
-> q DClause
mkSimpleConClause :: (Name -> [DExp] -> DExp) -> [DPat] -> DCon -> [DExp] -> q DClause
mkSimpleConClause Name -> [DExp] -> DExp
fold [DPat]
extra_pats (DCon [DTyVarBndr]
_ DCxt
_ Name
con_name DConFields
_ DType
_) [DExp]
insides = do
[Name]
vars_needed <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([DExp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
insides) (q Name -> q [Name]) -> q Name -> q [Name]
forall a b. (a -> b) -> a -> b
$ String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"a"
let pat :: DPat
pat = Name -> [DPat] -> DPat
DConP Name
con_name ((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
vars_needed)
rhs :: DExp
rhs = Name -> [DExp] -> DExp
fold Name
con_name ((DExp -> Name -> DExp) -> [DExp] -> [Name] -> [DExp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\DExp
i Name
v -> DExp
i DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
v) [DExp]
insides [Name]
vars_needed)
DClause -> q DClause
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause ([DPat]
extra_pats [DPat] -> [DPat] -> [DPat]
forall a. [a] -> [a] -> [a]
++ [DPat
pat]) DExp
rhs
isFunctorLikeClassName :: Name -> Bool
isFunctorLikeClassName :: Name -> Bool
isFunctorLikeClassName Name
class_name
= Name
class_name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
functorName, Name
foldableName, Name
traversableName]