{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :   Grisette.Internal.TH.DerivePredefined
-- Copyright   :   (c) Sirui Lu 2024
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
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]

-- | Derive instances for a type with the given name, with the predefined
-- strategy.
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
        []
        -- SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable False,
        -- SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable1 False

        ''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
        []
        -- SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable False,
        -- SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable1 False

        ''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
        [ -- SomeDeriveTypeParamHandler $ ModeTypeParamHandler evmode,
          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

-- | Derive instances for a type with the given name, with the predefined
-- strategy.
--
-- Multiple classes can be derived at once.
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 specified classes for a type with the given name.
--
-- Support the same set of classes as 'deriveAll'.
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

-- | Derive all classes related to Grisette for a type with the given name.
--
-- Classes that are be derived by this procedure are:
--
-- * 'Generic'
-- * 'Show'
-- * 'Eq'
-- * 'Ord'
-- * 'Lift'
-- * 'NFData'
-- * 'Hashable'
-- * 'AllSyms'
-- * 'EvalSym'
-- * 'ExtractSym'
-- * 'PPrint'
-- * 'Mergeable'
-- * 'SymEq'
-- * 'SymOrd'
-- * 'SubstSym'
-- * 'ToCon'
-- * 'ToSym'
-- * 'UnifiedSymEq'
-- * 'UnifiedSymOrd'
--
-- 'Ord' isn't valid for all types (symbolic-only types), so it may be necessary
-- to exclude it.
--
-- 'deriveAll' needs the following language extensions:
--
-- * DeriveAnyClass
-- * DeriveGeneric
-- * DeriveLift
-- * DerivingVia
-- * FlexibleContexts
-- * FlexibleInstances
-- * MonoLocalBinds
-- * MultiParamTypeClasses
-- * ScopedTypeVariables
-- * StandaloneDeriving
-- * TemplateHaskell
-- * TypeApplications
-- * UndecidableInstances
--
-- Deriving for a newtype may also need
--
-- * GeneralizedNewtypeDeriving
--
-- You may get warnings if you don't have the following extensions:
--
-- * TypeOperators
--
-- It also requires that the v'Generics.Deriving.Default.Default' data
-- constructor is visible.
-- You may get strange errors if you only import
-- v'Generics.Deriving.Default.Default' type but not the data constructor.
deriveAll :: Name -> Q [Dec]
deriveAll :: Name -> Q [Dec]
deriveAll = [Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses [Name]
allGrisetteClasses

-- | Derive all classes related to Grisette for a type with the given name,
-- except for the given classes.
--
-- Excluding 'Ord' or 'SymOrd' will also exclude 'UnifiedSymOrd'.
-- Excluding 'Eq' or 'SymEq' will also exclude 'UnifiedSymEq'.
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