{-# 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

import Control.DeepSeq (NFData, NFData1)
import Data.Functor.Classes (Eq1, Ord1, Show1)
import Data.Hashable (Hashable)
import Data.Hashable.Lifted (Hashable1)
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),
    PrimaryConstraint (PrimaryConstraint),
    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 (ConT, PromotedT),
    appT,
    conT,
    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 = String -> Q Strategy
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Strategy) -> String -> Q Strategy
forall a b. (a -> b) -> a -> b
$ String
"Unsupported class: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
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}

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]]
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 =
            String -> Q [Type]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 :: Maybe EvalModeTag -> Name -> Name -> Q [Dec]
derivePredefined :: Maybe EvalModeTag -> Name -> Name -> Q [Dec]
derivePredefined Maybe EvalModeTag
_ 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 Maybe EvalModeTag
_ 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
        [ PrimaryConstraint -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (PrimaryConstraint -> SomeDeriveTypeParamHandler)
-> PrimaryConstraint -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Name -> Bool -> PrimaryConstraint
PrimaryConstraint ''Mergeable Bool
False,
          PrimaryConstraint -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (PrimaryConstraint -> SomeDeriveTypeParamHandler)
-> PrimaryConstraint -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Name -> Bool -> PrimaryConstraint
PrimaryConstraint ''Mergeable1 Bool
False
        ]
        ''UnifiedSymEq
        'withBaseSymEq
        ''UnifiedSymEq1
        'withBaseSymEq1
        Name
name
derivePredefined Maybe EvalModeTag
_ 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
        [ PrimaryConstraint -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (PrimaryConstraint -> SomeDeriveTypeParamHandler)
-> PrimaryConstraint -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Name -> Bool -> PrimaryConstraint
PrimaryConstraint ''Mergeable Bool
False,
          PrimaryConstraint -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (PrimaryConstraint -> SomeDeriveTypeParamHandler)
-> PrimaryConstraint -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Name -> Bool -> PrimaryConstraint
PrimaryConstraint ''Mergeable1 Bool
False
        ]
        ''UnifiedSymOrd
        'withBaseSymOrd
        ''UnifiedSymOrd1
        'withBaseSymOrd1
        Name
name
derivePredefined Maybe EvalModeTag
evmode 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 ->
          String -> Q Strategy
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Currently only non-GADTs data or newtype are supported."
  [SomeDeriveTypeParamHandler]
-> Bool -> Strategy -> [Name] -> Name -> Q [Dec]
deriveBuiltinExtra
    [ ModeTypeParamHandler -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (ModeTypeParamHandler -> SomeDeriveTypeParamHandler)
-> ModeTypeParamHandler -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Maybe EvalModeTag -> ModeTypeParamHandler
ModeTypeParamHandler Maybe EvalModeTag
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 ::
  Maybe EvalModeTag -> [Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses :: Maybe EvalModeTag -> [Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses Maybe EvalModeTag
evmode [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
cls -> Maybe EvalModeTag -> Name -> Name -> Q [Dec]
derivePredefined Maybe EvalModeTag
evmode Name
cls 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 (Maybe EvalModeTag -> [Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses Maybe EvalModeTag
forall a. Maybe a
Nothing)

-- | 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 = Maybe EvalModeTag -> [Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses Maybe EvalModeTag
forall a. Maybe a
Nothing [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 =
  Maybe EvalModeTag -> [Name] -> Name -> Q [Dec]
derivePredefinedMultipleClasses
    Maybe EvalModeTag
forall a. Maybe a
Nothing
    ((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