{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Grisette.Internal.TH.DerivePredefined
( derivePredefined,
derivePredefinedMultipleClasses,
derive,
deriveAll,
deriveAllExcept,
)
where
#if MIN_VERSION_template_haskell(2,17,0)
import Language.Haskell.TH (Type (MulArrowT))
#endif
#if MIN_VERSION_template_haskell(2,19,0)
import Language.Haskell.TH (Type (PromotedInfixT, PromotedUInfixT))
#endif
import Control.DeepSeq (NFData, NFData1)
import Data.Functor.Classes (Eq1, Ord1, Show1)
import Data.Hashable (Hashable)
import Data.Hashable.Lifted (Hashable1)
import Data.List (nub)
import GHC.Generics (Generic)
import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym, EvalSym1)
import Grisette.Internal.Core.Data.Class.ExtractSym
( ExtractSym,
ExtractSym1,
)
import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, Mergeable1)
import Grisette.Internal.Core.Data.Class.PPrint (PPrint, PPrint1)
import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym)
import Grisette.Internal.Core.Data.Class.SymEq (SymEq, SymEq1)
import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd, SymOrd1)
import Grisette.Internal.Core.Data.Class.ToCon (ToCon, ToCon1)
import Grisette.Internal.Core.Data.Class.ToSym (ToSym, ToSym1)
import Grisette.Internal.SymPrim.AllSyms (AllSyms, AllSyms1)
import Grisette.Internal.TH.DeriveBuiltin
( deriveBuiltinExtra,
)
import Grisette.Internal.TH.DeriveInstanceProvider
( Strategy (Anyclass, Stock, ViaDefault, WithNewtype),
)
import Grisette.Internal.TH.DeriveTypeParamHandler
( DeriveTypeParamHandler (handleBody, handleTypeParams),
SomeDeriveTypeParamHandler (SomeDeriveTypeParamHandler),
)
import Grisette.Internal.TH.DeriveUnifiedInterface
( deriveFunctorArgUnifiedInterfaceExtra,
)
import Grisette.Internal.TH.DeriveWithHandlers (deriveWithHandlers)
import Grisette.Internal.TH.Util (classParamKinds, concatPreds)
import Grisette.Unified.Internal.Class.UnifiedSymEq
( UnifiedSymEq (withBaseSymEq),
UnifiedSymEq1 (withBaseSymEq1),
)
import Grisette.Unified.Internal.Class.UnifiedSymOrd
( UnifiedSymOrd (withBaseSymOrd),
UnifiedSymOrd1 (withBaseSymOrd1),
)
import Grisette.Unified.Internal.EvalMode (EvalMode)
import Grisette.Unified.Internal.EvalModeTag
( EvalModeTag (Con, Sym),
)
import Language.Haskell.TH
( Dec,
Kind,
Name,
Pred,
Q,
Type
( AppT,
ArrowT,
ConT,
EqualityT,
InfixT,
ListT,
LitT,
ParensT,
PromotedConsT,
PromotedNilT,
PromotedT,
PromotedTupleT,
TupleT,
UInfixT,
UnboxedSumT,
UnboxedTupleT,
VarT,
WildCardT
),
appT,
conT,
pprint,
varT,
)
import Language.Haskell.TH.Datatype
( DatatypeInfo (datatypeVariant),
DatatypeVariant (Datatype, Newtype),
reifyDatatype,
tvKind,
tvName,
)
import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit)
import Language.Haskell.TH.Syntax (Lift)
newtypeDefaultStrategy :: Name -> Q Strategy
newtypeDefaultStrategy :: Name -> Q Strategy
newtypeDefaultStrategy Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Show = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
Stock Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''PPrint = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Lift = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
Stock Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''ToCon = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''ToSym = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Bool
otherwise = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
WithNewtype Name
nm
dataDefaultStrategy :: Name -> Q Strategy
dataDefaultStrategy :: Name -> Q Strategy
dataDefaultStrategy Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Show = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
Stock Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Eq = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
Stock Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Ord = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
Stock Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Lift = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
Stock Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''NFData = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
Anyclass Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Hashable = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
Anyclass Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''ToCon = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''ToSym = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''AllSyms = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''EvalSym = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''ExtractSym = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''PPrint = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Mergeable = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''SymEq = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''SymOrd = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''SubstSym = Strategy -> Q Strategy
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Strategy -> Q Strategy) -> Strategy -> Q Strategy
forall a b. (a -> b) -> a -> b
$ Name -> Strategy
ViaDefault Name
nm
| Bool
otherwise = [Char] -> Q Strategy
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Strategy) -> [Char] -> Q Strategy
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported class: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Name -> [Char]
forall a. Show a => a -> [Char]
show Name
nm
allNeededConstraints :: Name -> [Name]
allNeededConstraints :: Name -> [Name]
allNeededConstraints Name
nm
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Show = [''Show, ''Show1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Eq = [''Eq, ''Eq1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Ord = [''Ord, ''Ord1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Lift = [''Lift]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''NFData = [''NFData, ''NFData1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Hashable = [''Hashable, ''Hashable1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''AllSyms = [''AllSyms, ''AllSyms1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''EvalSym =
[''EvalSym, ''EvalSym1, ''Mergeable, ''Mergeable1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''ExtractSym = [''ExtractSym, ''ExtractSym1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''PPrint = [''PPrint, ''PPrint1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Mergeable = [''Mergeable1, ''Mergeable1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''ToCon = [''ToCon, ''ToCon1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''ToSym = [''ToSym, ''ToSym1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''SymEq = [''SymEq, ''SymEq1, ''Mergeable, ''Mergeable1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''SymOrd = [''SymOrd, ''SymOrd1, ''Mergeable, ''Mergeable1]
| Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''SubstSym =
[''SubstSym, ''SubstSym, ''Mergeable, ''Mergeable1]
| Bool
otherwise = []
newtype ModeTypeParamHandler = ModeTypeParamHandler
{ ModeTypeParamHandler -> Maybe EvalModeTag
mode :: Maybe EvalModeTag
}
instance DeriveTypeParamHandler ModeTypeParamHandler where
handleTypeParams :: Int
-> ModeTypeParamHandler
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
handleTypeParams Int
_ ModeTypeParamHandler {Maybe EvalModeTag
mode :: ModeTypeParamHandler -> Maybe EvalModeTag
mode :: Maybe EvalModeTag
..} [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys = do
(([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type]))
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type] -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type]))
-> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type] -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
handle) [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys
where
handle ::
[(TyVarBndrUnit, Maybe Type)] ->
Maybe [Pred] ->
Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])
handle :: [(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type] -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
handle [(TyVarBndrUnit
ty, Maybe Type
substTy)] Maybe [Type]
preds | TyVarBndrUnit -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndrUnit
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''EvalModeTag =
case (Maybe EvalModeTag
mode, Maybe Type
substTy) of
(Maybe EvalModeTag
_, Just {}) -> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVarBndrUnit
ty, Maybe Type
substTy)], Maybe [Type]
preds)
(Just EvalModeTag
Con, Maybe Type
_) -> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVarBndrUnit
ty, Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
PromotedT 'Con)], Maybe [Type]
preds)
(Just EvalModeTag
Sym, Maybe Type
_) -> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVarBndrUnit
ty, Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
PromotedT 'Sym)], Maybe [Type]
preds)
(Maybe EvalModeTag
Nothing, Maybe Type
_) -> do
Type
evalMode <- [t|EvalMode $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
ty)|]
([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVarBndrUnit
ty, Maybe Type
substTy)], Maybe [Type] -> Maybe [Type] -> Maybe [Type]
concatPreds ([Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type
evalMode]) Maybe [Type]
preds)
handle [(TyVarBndrUnit, Maybe Type)]
tys Maybe [Type]
preds = ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVarBndrUnit, Maybe Type)]
tys, Maybe [Type]
preds)
handleBody :: ModeTypeParamHandler -> [[Type]] -> Q [Type]
handleBody ModeTypeParamHandler
_ [[Type]]
_ = [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
newtype FixInnerConstraints = FixInnerConstraints {FixInnerConstraints -> Name
cls :: Name}
needFix :: Type -> Bool
needFix :: Type -> Bool
needFix (AppT Type
a Type
b) = Type -> Bool
needFix Type
a Bool -> Bool -> Bool
|| Type -> Bool
needFix Type
b
needFix VarT {} = Bool
True
needFix ConT {} = Bool
False
needFix PromotedT {} = Bool
False
needFix (InfixT Type
a Name
_ Type
b) = Type -> Bool
needFix Type
a Bool -> Bool -> Bool
|| Type -> Bool
needFix Type
b
needFix (UInfixT Type
a Name
_ Type
b) = Type -> Bool
needFix Type
a Bool -> Bool -> Bool
|| Type -> Bool
needFix Type
b
needFix (ParensT Type
a) = Type -> Bool
needFix Type
a
needFix TupleT {} = Bool
False
needFix UnboxedTupleT {} = Bool
False
needFix UnboxedSumT {} = Bool
False
needFix Type
ArrowT = Bool
False
needFix Type
EqualityT = Bool
False
needFix Type
ListT = Bool
False
needFix PromotedTupleT {} = Bool
False
needFix Type
PromotedNilT = Bool
False
needFix Type
PromotedConsT = Bool
False
needFix LitT {} = Bool
False
needFix Type
WildCardT = Bool
False
#if MIN_VERSION_template_haskell(2,17,0)
needFix Type
MulArrowT = Bool
False
#endif
#if MIN_VERSION_template_haskell(2,19,0)
needFix (PromotedInfixT Type
a Name
_ Type
b) = Type -> Bool
needFix Type
a Bool -> Bool -> Bool
|| Type -> Bool
needFix Type
b
needFix (PromotedUInfixT Type
a Name
_ Type
b) = Type -> Bool
needFix Type
a Bool -> Bool -> Bool
|| Type -> Bool
needFix Type
b
#endif
needFix Type
t = [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported type in derivation: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
t
instance DeriveTypeParamHandler FixInnerConstraints where
handleTypeParams :: Int
-> FixInnerConstraints
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
handleTypeParams Int
_ FixInnerConstraints
_ = [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
handleBody :: FixInnerConstraints -> [[Type]] -> Q [Type]
handleBody FixInnerConstraints {Name
cls :: FixInnerConstraints -> Name
cls :: Name
..} [[Type]]
types = do
[Type]
kinds <- Name -> Q [Type]
classParamKinds Name
cls
[[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type]) -> Q [[Type]] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Type] -> Q [Type]) -> [[Type]] -> Q [[Type]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Type] -> [Type] -> Q [Type]
handle [Type]
kinds) (([Type] -> Bool) -> [[Type]] -> [[Type]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
needFix) ([[Type]] -> [[Type]]) -> [[Type]] -> [[Type]]
forall a b. (a -> b) -> a -> b
$ [[Type]] -> [[Type]]
forall a. Eq a => [a] -> [a]
nub [[Type]]
types)
where
handle :: [Kind] -> [Type] -> Q [Pred]
handle :: [Type] -> [Type] -> Q [Type]
handle [Type]
k [Type]
tys
| [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys =
[Char] -> Q [Type]
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"FixInnerConstraints: kind and type length mismatch"
| Bool
otherwise = do
Type
constr <- (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
cls) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
tys
[Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type
constr]
derivePredefined :: Name -> Name -> Q [Dec]
derivePredefined :: Name -> Name -> Q [Dec]
derivePredefined Name
cls Name
name
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Generic =
[SomeDeriveTypeParamHandler]
-> Strategy -> Bool -> Int -> [Name] -> Q [Dec]
forall provider.
DeriveInstanceProvider provider =>
[SomeDeriveTypeParamHandler]
-> provider -> Bool -> Int -> [Name] -> Q [Dec]
deriveWithHandlers [] (Name -> Strategy
Stock ''Generic) Bool
True Int
0 [Name
name]
derivePredefined Name
cls Name
name
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''UnifiedSymEq =
[SomeDeriveTypeParamHandler]
-> Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveFunctorArgUnifiedInterfaceExtra
[]
''UnifiedSymEq
'withBaseSymEq
''UnifiedSymEq1
'withBaseSymEq1
Name
name
derivePredefined Name
cls Name
name
| Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''UnifiedSymOrd =
[SomeDeriveTypeParamHandler]
-> Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveFunctorArgUnifiedInterfaceExtra
[]
''UnifiedSymOrd
'withBaseSymOrd
''UnifiedSymOrd1
'withBaseSymOrd1
Name
name
derivePredefined Name
cls Name
name = do
DatatypeInfo
d <- Name -> Q DatatypeInfo
reifyDatatype Name
name
Strategy
strategy <-
if
| DatatypeInfo -> DatatypeVariant
datatypeVariant DatatypeInfo
d DatatypeVariant -> DatatypeVariant -> Bool
forall a. Eq a => a -> a -> Bool
== DatatypeVariant
Datatype -> Name -> Q Strategy
dataDefaultStrategy Name
cls
| DatatypeInfo -> DatatypeVariant
datatypeVariant DatatypeInfo
d DatatypeVariant -> DatatypeVariant -> Bool
forall a. Eq a => a -> a -> Bool
== DatatypeVariant
Newtype -> Name -> Q Strategy
newtypeDefaultStrategy Name
cls
| Bool
otherwise ->
[Char] -> Q Strategy
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Currently only non-GADTs data or newtype are supported."
[SomeDeriveTypeParamHandler]
-> Maybe [SomeDeriveTypeParamHandler]
-> Bool
-> Strategy
-> [Name]
-> Name
-> Q [Dec]
deriveBuiltinExtra
[]
( [SomeDeriveTypeParamHandler] -> Maybe [SomeDeriveTypeParamHandler]
forall a. a -> Maybe a
Just
[
FixInnerConstraints -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (FixInnerConstraints -> SomeDeriveTypeParamHandler)
-> FixInnerConstraints -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Name -> FixInnerConstraints
FixInnerConstraints Name
cls
]
)
Bool
False
Strategy
strategy
(Name -> [Name]
allNeededConstraints Name
cls)
Name
name
derivePredefinedMultipleClasses ::
[Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses :: [Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses [Name]
clss Name
name =
[[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Name -> Name -> Q [Dec]
`derivePredefined` Name
name) [Name]
clss
allGrisetteClasses :: [Name]
allGrisetteClasses :: [Name]
allGrisetteClasses =
[ ''Generic,
''Show,
''Eq,
''Ord,
''Lift,
''NFData,
''Hashable,
''AllSyms,
''EvalSym,
''ExtractSym,
''PPrint,
''Mergeable,
''SymEq,
''SymOrd,
''SubstSym,
''ToCon,
''ToSym,
''UnifiedSymEq,
''UnifiedSymOrd
]
derive :: Name -> [Name] -> Q [Dec]
derive :: Name -> [Name] -> Q [Dec]
derive = ([Name] -> Name -> Q [Dec]) -> Name -> [Name] -> Q [Dec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses
deriveAll :: Name -> Q [Dec]
deriveAll :: Name -> Q [Dec]
deriveAll = [Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses [Name]
allGrisetteClasses
deriveAllExcept :: Name -> [Name] -> Q [Dec]
deriveAllExcept :: Name -> [Name] -> Q [Dec]
deriveAllExcept Name
nm [Name]
clss =
[Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses
((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
allExcluded) [Name]
allGrisetteClasses)
Name
nm
where
allExcluded :: [Name]
allExcluded =
([''UnifiedSymEq | ''Eq Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
clss Bool -> Bool -> Bool
|| ''SymEq Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
clss])
[Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> ([''UnifiedSymOrd | ''Ord Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
clss Bool -> Bool -> Bool
|| ''SymOrd Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
clss])
[Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> [Name]
clss