{-# LANGUAGE LambdaCase #-}
{-# HLINT ignore "Unused LANGUAGE pragma" #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

-- |
-- Module      :   Grisette.Internal.TH.Derivation.Derive
-- 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.Derivation.Derive
  ( derive,
    deriveWith,
    allClasses0,
    allClasses01,
    allClasses012,
    basicClasses0,
    noExistentialClasses0,
    concreteOrdClasses0,
    basicClasses1,
    noExistentialClasses1,
    concreteOrdClasses1,
    basicClasses2,
    noExistentialClasses2,
    concreteOrdClasses2,
    showClasses,
    pprintClasses,
    evalSymClasses,
    extractSymClasses,
    substSymClasses,
    allSymsClasses,
    eqClasses,
    ordClasses,
    symOrdClasses,
    symEqClasses,
    unifiedSymOrdClasses,
    unifiedSymEqClasses,
    mergeableClasses,
    nfDataClasses,
    hashableClasses,
    toSymClasses,
    toConClasses,
    serialClasses,
    simpleMergeableClasses,
    unifiedSimpleMergeableClasses,
    filterExactNumArgs,
    filterLeqNumArgs,
  )
where

import Control.Arrow (Arrow (second))
import Control.DeepSeq (NFData, NFData1, NFData2)
import Data.Binary (Binary)
import Data.Bytes.Serial (Serial, Serial1, Serial2)
import Data.Functor.Classes (Eq1, Eq2, Ord1, Ord2, Show1, Show2)
import Data.Hashable (Hashable)
import Data.Hashable.Lifted (Hashable1, Hashable2)
import qualified Data.Map as M
import Data.Serialize (Serialize)
import qualified Data.Set as S
import Grisette.Internal.Internal.Decl.Core.Data.Class.EvalSym
  ( EvalSym,
    EvalSym1,
    EvalSym2,
  )
import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym
  ( ExtractSym,
    ExtractSym1,
    ExtractSym2,
  )
import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable
  ( Mergeable,
    Mergeable1,
    Mergeable2,
    Mergeable3,
  )
import Grisette.Internal.Internal.Decl.Core.Data.Class.PPrint
  ( PPrint,
    PPrint1,
    PPrint2,
  )
import Grisette.Internal.Internal.Decl.Core.Data.Class.SimpleMergeable
  ( SimpleMergeable,
    SimpleMergeable1,
    SimpleMergeable2,
  )
import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym
  ( SubstSym,
    SubstSym1,
    SubstSym2,
  )
import Grisette.Internal.Internal.Decl.Core.Data.Class.SymEq
  ( SymEq,
    SymEq1,
    SymEq2,
  )
import Grisette.Internal.Internal.Decl.Core.Data.Class.SymOrd
  ( SymOrd,
    SymOrd1,
    SymOrd2,
  )
import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon
  ( ToCon,
    ToCon1,
    ToCon2,
  )
import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym
  ( ToSym,
    ToSym1,
    ToSym2,
  )
import Grisette.Internal.Internal.Decl.SymPrim.AllSyms
  ( AllSyms,
    AllSyms1,
    AllSyms2,
  )
import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable
  ( UnifiedSimpleMergeable,
    UnifiedSimpleMergeable1,
    UnifiedSimpleMergeable2,
  )
import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq
  ( UnifiedSymEq,
    UnifiedSymEq1,
    UnifiedSymEq2,
  )
import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymOrd
  ( UnifiedSymOrd,
    UnifiedSymOrd1,
    UnifiedSymOrd2,
  )
import Grisette.Internal.TH.Derivation.Common
  ( DeriveConfig
      ( evalModeConfig,
        needExtraMergeableUnderEvalMode,
        needExtraMergeableWithConcretizedEvalMode
      ),
    EvalModeConfig (EvalModeConstraints, EvalModeSpecified),
  )
import Grisette.Internal.TH.Derivation.DeriveAllSyms
  ( deriveAllSyms,
    deriveAllSyms1,
    deriveAllSyms2,
  )
import Grisette.Internal.TH.Derivation.DeriveBinary (deriveBinary)
import Grisette.Internal.TH.Derivation.DeriveCereal (deriveCereal)
import Grisette.Internal.TH.Derivation.DeriveEq
  ( deriveEq,
    deriveEq1,
    deriveEq2,
  )
import Grisette.Internal.TH.Derivation.DeriveEvalSym
  ( deriveEvalSym,
    deriveEvalSym1,
    deriveEvalSym2,
  )
import Grisette.Internal.TH.Derivation.DeriveExtractSym
  ( deriveExtractSym,
    deriveExtractSym1,
    deriveExtractSym2,
  )
import Grisette.Internal.TH.Derivation.DeriveHashable
  ( deriveHashable,
    deriveHashable1,
    deriveHashable2,
  )
import Grisette.Internal.TH.Derivation.DeriveMergeable (genMergeableList)
import Grisette.Internal.TH.Derivation.DeriveNFData
  ( deriveNFData,
    deriveNFData1,
    deriveNFData2,
  )
import Grisette.Internal.TH.Derivation.DeriveOrd
  ( deriveOrd,
    deriveOrd1,
    deriveOrd2,
  )
import Grisette.Internal.TH.Derivation.DerivePPrint
  ( derivePPrint,
    derivePPrint1,
    derivePPrint2,
  )
import Grisette.Internal.TH.Derivation.DeriveSerial
  ( deriveSerial,
    deriveSerial1,
    deriveSerial2,
  )
import Grisette.Internal.TH.Derivation.DeriveShow
  ( deriveShow,
    deriveShow1,
    deriveShow2,
  )
import Grisette.Internal.TH.Derivation.DeriveSimpleMergeable
  ( deriveSimpleMergeable,
    deriveSimpleMergeable1,
    deriveSimpleMergeable2,
  )
import Grisette.Internal.TH.Derivation.DeriveSubstSym
  ( deriveSubstSym,
    deriveSubstSym1,
    deriveSubstSym2,
  )
import Grisette.Internal.TH.Derivation.DeriveSymEq
  ( deriveSymEq,
    deriveSymEq1,
    deriveSymEq2,
  )
import Grisette.Internal.TH.Derivation.DeriveSymOrd
  ( deriveSymOrd,
    deriveSymOrd1,
    deriveSymOrd2,
  )
import Grisette.Internal.TH.Derivation.DeriveToCon
  ( deriveToCon,
    deriveToCon1,
    deriveToCon2,
  )
import Grisette.Internal.TH.Derivation.DeriveToSym
  ( deriveToSym,
    deriveToSym1,
    deriveToSym2,
  )
import Grisette.Internal.TH.Derivation.DeriveUnifiedSimpleMergeable
  ( deriveUnifiedSimpleMergeable,
    deriveUnifiedSimpleMergeable1,
    deriveUnifiedSimpleMergeable2,
  )
import Grisette.Internal.TH.Derivation.DeriveUnifiedSymEq
  ( deriveUnifiedSymEq,
    deriveUnifiedSymEq1,
    deriveUnifiedSymEq2,
  )
import Grisette.Internal.TH.Derivation.DeriveUnifiedSymOrd
  ( deriveUnifiedSymOrd,
    deriveUnifiedSymOrd1,
    deriveUnifiedSymOrd2,
  )
import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))
import Language.Haskell.TH (Dec, Name, Q)

deriveProcedureMap :: M.Map Name (DeriveConfig -> Name -> Q [Dec])
deriveProcedureMap :: Map Name (DeriveConfig -> Name -> Q [Dec])
deriveProcedureMap =
  [(Name, DeriveConfig -> Name -> Q [Dec])]
-> Map Name (DeriveConfig -> Name -> Q [Dec])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    [ (''EvalSym, DeriveConfig -> Name -> Q [Dec]
deriveEvalSym),
      (''EvalSym1, DeriveConfig -> Name -> Q [Dec]
deriveEvalSym1),
      (''EvalSym2, DeriveConfig -> Name -> Q [Dec]
deriveEvalSym2),
      (''ExtractSym, DeriveConfig -> Name -> Q [Dec]
deriveExtractSym),
      (''ExtractSym1, DeriveConfig -> Name -> Q [Dec]
deriveExtractSym1),
      (''ExtractSym2, DeriveConfig -> Name -> Q [Dec]
deriveExtractSym2),
      (''SubstSym, DeriveConfig -> Name -> Q [Dec]
deriveSubstSym),
      (''SubstSym1, DeriveConfig -> Name -> Q [Dec]
deriveSubstSym1),
      (''SubstSym2, DeriveConfig -> Name -> Q [Dec]
deriveSubstSym2),
      (''NFData, DeriveConfig -> Name -> Q [Dec]
deriveNFData),
      (''NFData1, DeriveConfig -> Name -> Q [Dec]
deriveNFData1),
      (''NFData2, DeriveConfig -> Name -> Q [Dec]
deriveNFData2),
      (''Hashable, DeriveConfig -> Name -> Q [Dec]
deriveHashable),
      (''Hashable1, DeriveConfig -> Name -> Q [Dec]
deriveHashable1),
      (''Hashable2, DeriveConfig -> Name -> Q [Dec]
deriveHashable2),
      (''Show, DeriveConfig -> Name -> Q [Dec]
deriveShow),
      (''Show1, DeriveConfig -> Name -> Q [Dec]
deriveShow1),
      (''Show2, DeriveConfig -> Name -> Q [Dec]
deriveShow2),
      (''PPrint, DeriveConfig -> Name -> Q [Dec]
derivePPrint),
      (''PPrint1, DeriveConfig -> Name -> Q [Dec]
derivePPrint1),
      (''PPrint2, DeriveConfig -> Name -> Q [Dec]
derivePPrint2),
      (''AllSyms, DeriveConfig -> Name -> Q [Dec]
deriveAllSyms),
      (''AllSyms1, DeriveConfig -> Name -> Q [Dec]
deriveAllSyms1),
      (''AllSyms2, DeriveConfig -> Name -> Q [Dec]
deriveAllSyms2),
      (''Eq, DeriveConfig -> Name -> Q [Dec]
deriveEq),
      (''Eq1, DeriveConfig -> Name -> Q [Dec]
deriveEq1),
      (''Eq2, DeriveConfig -> Name -> Q [Dec]
deriveEq2),
      (''Ord, DeriveConfig -> Name -> Q [Dec]
deriveOrd),
      (''Ord1, DeriveConfig -> Name -> Q [Dec]
deriveOrd1),
      (''Ord2, DeriveConfig -> Name -> Q [Dec]
deriveOrd2),
      (''SymOrd, DeriveConfig -> Name -> Q [Dec]
deriveSymOrd),
      (''SymOrd1, DeriveConfig -> Name -> Q [Dec]
deriveSymOrd1),
      (''SymOrd2, DeriveConfig -> Name -> Q [Dec]
deriveSymOrd2),
      (''SymEq, DeriveConfig -> Name -> Q [Dec]
deriveSymEq),
      (''SymEq1, DeriveConfig -> Name -> Q [Dec]
deriveSymEq1),
      (''SymEq2, DeriveConfig -> Name -> Q [Dec]
deriveSymEq2),
      (''UnifiedSymEq, DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymEq),
      (''UnifiedSymEq1, DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymEq1),
      (''UnifiedSymEq2, DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymEq2),
      (''UnifiedSymOrd, DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymOrd),
      (''UnifiedSymOrd1, DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymOrd1),
      (''UnifiedSymOrd2, DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymOrd2),
      (''ToSym, DeriveConfig -> Name -> Q [Dec]
deriveToSym),
      (''ToSym1, DeriveConfig -> Name -> Q [Dec]
deriveToSym1),
      (''ToSym2, DeriveConfig -> Name -> Q [Dec]
deriveToSym2),
      (''ToCon, DeriveConfig -> Name -> Q [Dec]
deriveToCon),
      (''ToCon1, DeriveConfig -> Name -> Q [Dec]
deriveToCon1),
      (''ToCon2, DeriveConfig -> Name -> Q [Dec]
deriveToCon2),
      (''Serial, DeriveConfig -> Name -> Q [Dec]
deriveSerial),
      (''Serial1, DeriveConfig -> Name -> Q [Dec]
deriveSerial1),
      (''Serial2, DeriveConfig -> Name -> Q [Dec]
deriveSerial2),
      (''SimpleMergeable, DeriveConfig -> Name -> Q [Dec]
deriveSimpleMergeable),
      (''SimpleMergeable1, DeriveConfig -> Name -> Q [Dec]
deriveSimpleMergeable1),
      (''SimpleMergeable2, DeriveConfig -> Name -> Q [Dec]
deriveSimpleMergeable2),
      (''UnifiedSimpleMergeable, DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSimpleMergeable),
      (''UnifiedSimpleMergeable1, DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSimpleMergeable1),
      (''UnifiedSimpleMergeable2, DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSimpleMergeable2),
      (''Binary, DeriveConfig -> Name -> Q [Dec]
deriveBinary),
      (''Serialize, DeriveConfig -> Name -> Q [Dec]
deriveCereal)
    ]

deriveSingle :: DeriveConfig -> Name -> Name -> Q [Dec]
deriveSingle :: DeriveConfig -> Name -> Name -> Q [Dec]
deriveSingle DeriveConfig
deriveConfig Name
typName Name
className = do
  let newExtra :: DeriveConfig
newExtra
        | Name
className
            Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ ''Eq,
                     ''Eq1,
                     ''Eq2,
                     ''SymEq,
                     ''SymEq1,
                     ''SymEq2,
                     ''SymOrd,
                     ''SymOrd1,
                     ''SymOrd2,
                     ''UnifiedSymEq,
                     ''UnifiedSymEq1,
                     ''UnifiedSymEq2,
                     ''UnifiedSymOrd,
                     ''UnifiedSymOrd1,
                     ''UnifiedSymOrd2,
                     ''UnifiedSimpleMergeable,
                     ''UnifiedSimpleMergeable1,
                     ''UnifiedSimpleMergeable2
                   ] =
            DeriveConfig
deriveConfig
              { needExtraMergeableUnderEvalMode = False,
                needExtraMergeableWithConcretizedEvalMode = False
              }
        | Name
className
            Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [''SimpleMergeable, ''SimpleMergeable1, ''SimpleMergeable2] =
            DeriveConfig
deriveConfig
              { evalModeConfig =
                  second
                    ( \case
                        EvalModeConstraints [Name]
_ -> EvalModeTag -> EvalModeConfig
EvalModeSpecified EvalModeTag
S
                        EvalModeSpecified EvalModeTag
tag -> EvalModeTag -> EvalModeConfig
EvalModeSpecified EvalModeTag
tag
                    )
                    <$> evalModeConfig deriveConfig,
                needExtraMergeableUnderEvalMode = False,
                needExtraMergeableWithConcretizedEvalMode = False
              }
        | Name
className Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [''Ord, ''Ord1, ''Ord2] =
            DeriveConfig
deriveConfig
              { evalModeConfig =
                  second
                    ( \case
                        EvalModeConstraints [Name]
_ -> EvalModeTag -> EvalModeConfig
EvalModeSpecified EvalModeTag
C
                        EvalModeSpecified EvalModeTag
tag -> EvalModeTag -> EvalModeConfig
EvalModeSpecified EvalModeTag
tag
                    )
                    <$> evalModeConfig deriveConfig,
                needExtraMergeableUnderEvalMode = False,
                needExtraMergeableWithConcretizedEvalMode = False
              }
        | Bool
otherwise = DeriveConfig
deriveConfig
  case Name
-> Map Name (DeriveConfig -> Name -> Q [Dec])
-> Maybe (DeriveConfig -> Name -> Q [Dec])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
className Map Name (DeriveConfig -> Name -> Q [Dec])
deriveProcedureMap of
    Just DeriveConfig -> Name -> Q [Dec]
procedure -> DeriveConfig -> Name -> Q [Dec]
procedure DeriveConfig
newExtra Name
typName
    Maybe (DeriveConfig -> Name -> Q [Dec])
Nothing ->
      String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"No derivation available for class " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
className

deriveWith' :: DeriveConfig -> Name -> [Name] -> Q [Dec]
deriveWith' :: DeriveConfig -> Name -> [Name] -> Q [Dec]
deriveWith' DeriveConfig
deriveConfig Name
typName [Name]
classNameList = do
  let classNames :: Set Name
classNames = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList [Name]
classNameList
  let ([Name]
ns, [Int]
ms) = [Name] -> ([Name], [Int])
splitMergeable ([Name] -> ([Name], [Int])) -> [Name] -> ([Name], [Int])
forall a b. (a -> b) -> a -> b
$ Set Name -> [Name]
forall a. Set a -> [a]
S.toList Set Name
classNames
  decs <- (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
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 (DeriveConfig -> Name -> Name -> Q [Dec]
deriveSingle DeriveConfig
deriveConfig Name
typName) [Name]
ns
  decMergeables <- deriveMergeables ms
  return $ concat decs ++ decMergeables
  where
    configWithOutExtraMergeable :: DeriveConfig
    configWithOutExtraMergeable :: DeriveConfig
configWithOutExtraMergeable =
      DeriveConfig
deriveConfig {needExtraMergeableUnderEvalMode = False}
    deriveMergeables :: [Int] -> Q [Dec]
    deriveMergeables :: [Int] -> Q [Dec]
deriveMergeables = DeriveConfig -> Name -> [Int] -> Q [Dec]
genMergeableList DeriveConfig
configWithOutExtraMergeable Name
typName
    splitMergeable :: [Name] -> ([Name], [Int])
    splitMergeable :: [Name] -> ([Name], [Int])
splitMergeable [] = ([], [])
    splitMergeable (Name
x : [Name]
xs) =
      let ([Name]
ns, [Int]
is) = [Name] -> ([Name], [Int])
splitMergeable [Name]
xs
       in if
            | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Mergeable -> ([Name]
ns, Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
is)
            | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Mergeable1 -> ([Name]
ns, Int
1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
is)
            | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Mergeable2 -> ([Name]
ns, Int
2 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
is)
            | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Mergeable3 -> ([Name]
ns, Int
3 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
is)
            | Bool
otherwise -> (Name
x Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
ns, [Int]
is)

-- | Derive the specified classes for a data type with the given name.
--
-- Support the following classes for both vanilla data types and GADTs.
--
-- * 'Mergeable'
-- * 'Mergeable1'
-- * 'Mergeable2'
-- * 'Mergeable3'
-- * 'EvalSym'
-- * 'EvalSym1'
-- * 'EvalSym2'
-- * 'ExtractSym'
-- * 'ExtractSym1'
-- * 'ExtractSym2'
-- * 'SubstSym'
-- * 'SubstSym1'
-- * 'SubstSym2'
-- * 'NFData'
-- * 'NFData1'
-- * 'NFData2'
-- * 'Hashable'
-- * 'Hashable1'
-- * 'Hashable2'
-- * 'Show'
-- * 'Show1'
-- * 'Show2'
-- * 'PPrint'
-- * 'PPrint1'
-- * 'PPrint2'
-- * 'AllSyms'
-- * 'AllSyms1'
-- * 'AllSyms2'
-- * 'Eq'
-- * 'Eq1'
-- * 'Eq2'
-- * 'Ord'
-- * 'Ord1'
-- * 'Ord2'
-- * 'SymOrd'
-- * 'SymOrd1'
-- * 'SymOrd2'
-- * 'SymEq'
-- * 'SymEq1'
-- * 'SymEq2'
-- * 'UnifiedSymEq'
-- * 'UnifiedSymEq1'
-- * 'UnifiedSymEq2'
-- * 'UnifiedSymOrd'
-- * 'UnifiedSymOrd1'
-- * 'UnifiedSymOrd2'
-- * 'ToSym'
-- * 'ToSym1'
-- * 'ToSym2'
-- * 'ToCon'
-- * 'ToCon1'
-- * 'ToCon2'
-- * 'Serial'
-- * 'Serial1'
-- * 'Serial2'
-- * 'SimpleMergeable'
-- * 'SimpleMergeable1'
-- * 'SimpleMergeable2'
-- * 'Binary'
-- * 'Serialize'
--
-- Note that the following type classes cannot be derived for GADTs with
-- existential type variables.
--
-- * 'ToCon'
-- * 'ToCon1'
-- * 'ToCon2'
-- * 'ToSym'
-- * 'ToSym1'
-- * 'ToSym2'
-- * 'Serial'
-- * 'Serial1'
-- * 'Serial2'
-- * 'Binary'
-- * 'Serialize'
deriveWith :: DeriveConfig -> [Name] -> [Name] -> Q [Dec]
deriveWith :: DeriveConfig -> [Name] -> [Name] -> Q [Dec]
deriveWith DeriveConfig
deriveConfig [Name]
typeNameList [Name]
classNameList = do
  let typeNames :: [Name]
typeNames = Set Name -> [Name]
forall a. Set a -> [a]
S.toList (Set Name -> [Name]) -> Set Name -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList [Name]
typeNameList
  [[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
typeName -> DeriveConfig -> Name -> [Name] -> Q [Dec]
deriveWith' DeriveConfig
deriveConfig Name
typeName [Name]
classNameList)
      [Name]
typeNames

-- | Derive the specified classes for a data type with the given name.
--
-- See 'deriveWith' for more details.
derive :: [Name] -> [Name] -> Q [Dec]
derive :: [Name] -> [Name] -> Q [Dec]
derive = DeriveConfig -> [Name] -> [Name] -> Q [Dec]
deriveWith DeriveConfig
forall a. Monoid a => a
mempty

-- | All the classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'Mergeable'
-- * 'EvalSym'
-- * 'ExtractSym'
-- * 'SubstSym'
-- * 'NFData'
-- * 'Hashable'
-- * 'Show'
-- * 'PPrint'
-- * 'AllSyms'
-- * 'Eq'
-- * 'SymEq'
-- * 'SymOrd'
-- * 'UnifiedSymEq'
-- * 'Ord'
-- * 'UnifiedSymOrd'
-- * 'Serial'
-- * 'ToCon'
-- * 'ToSym'
allClasses0 :: [Name]
allClasses0 :: [Name]
allClasses0 = [Name]
basicClasses0 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
concreteOrdClasses0 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
noExistentialClasses0

-- | All the @*1@ classes that can be derived for GADT functors.
--
-- This includes:
--
-- * 'Mergeable1'
-- * 'EvalSym1'
-- * 'ExtractSym1'
-- * 'SubstSym1'
-- * 'NFData1'
-- * 'Hashable1'
-- * 'Show1'
-- * 'PPrint1'
-- * 'AllSyms1'
-- * 'Eq1'
-- * 'SymEq1'
-- * 'SymOrd1'
-- * 'UnifiedSymEq1'
-- * 'Ord1'
-- * 'UnifiedSymOrd1'
-- * 'Serial1'
-- * 'ToCon1'
-- * 'ToSym1'
allClasses1 :: [Name]
allClasses1 :: [Name]
allClasses1 = [Name]
basicClasses1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
concreteOrdClasses1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
noExistentialClasses1

-- | All the classes that can be derived for GADT functors.
--
-- This includes all the classes in 'allClasses0' and 'allClasses1'.
allClasses01 :: [Name]
allClasses01 :: [Name]
allClasses01 = [Name]
allClasses0 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
allClasses1

-- | All the @*2@ classes that can be derived for GADT functors.
--
-- This includes:
--
-- * 'Mergeable2'
-- * 'EvalSym2'
-- * 'ExtractSym2'
-- * 'SubstSym2'
-- * 'NFData2'
-- * 'Hashable2'
-- * 'Show2'
-- * 'PPrint2'
-- * 'AllSyms2'
-- * 'Eq2'
-- * 'SymEq2'
-- * 'SymOrd2'
-- * 'UnifiedSymEq2'
-- * 'Ord2'
-- * 'UnifiedSymOrd2'
-- * 'Serial2'
-- * 'ToCon2'
-- * 'ToSym2'
allClasses2 :: [Name]
allClasses2 :: [Name]
allClasses2 = [Name]
basicClasses2 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
concreteOrdClasses2 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
noExistentialClasses2

-- | All the classes that can be derived for GADT functors.
--
-- This includes all the classes in 'allClasses0', 'allClasses1',
-- and 'allClasses2'.
allClasses012 :: [Name]
allClasses012 :: [Name]
allClasses012 = [Name]
allClasses0 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
allClasses1 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
allClasses2

-- | Basic classes for GADTs.
--
-- This includes:
--
-- * 'Mergeable'
-- * 'EvalSym'
-- * 'ExtractSym'
-- * 'SubstSym'
-- * 'NFData'
-- * 'Hashable'
-- * 'Show'
-- * 'PPrint'
-- * 'AllSyms'
-- * 'Eq'
-- * 'SymEq'
-- * 'SymOrd'
-- * 'UnifiedSymEq'
--
-- These classes can be derived for most GADTs.
basicClasses0 :: [Name]
basicClasses0 :: [Name]
basicClasses0 =
  [ ''Mergeable,
    ''EvalSym,
    ''ExtractSym,
    ''SubstSym,
    ''NFData,
    ''Hashable,
    ''Show,
    ''PPrint,
    ''AllSyms,
    ''Eq,
    ''SymEq,
    ''SymOrd,
    ''UnifiedSymEq
  ]

-- | Classes that can only be derived for GADTs without existential type
-- variables.
--
-- This includes:
--
-- * 'Serial'
-- * 'Serialize'
-- * 'Binary'
-- * 'ToCon'
-- * 'ToSym'
noExistentialClasses0 :: [Name]
noExistentialClasses0 :: [Name]
noExistentialClasses0 = [''Serial, ''ToCon, ''ToSym, ''Serialize, ''Binary]

-- | Concrete ordered classes that can be derived for GADTs that
--
-- * uses unified evaluation mode, or
-- * does not contain any symbolic variables.
--
-- This includes:
--
-- * 'Ord'
-- * 'UnifiedSymOrd'
concreteOrdClasses0 :: [Name]
concreteOrdClasses0 :: [Name]
concreteOrdClasses0 = [''Ord, ''UnifiedSymOrd]

-- | Basic classes for GADT functors.
--
-- This includes:
--
-- * 'Mergeable1'
-- * 'EvalSym1'
-- * 'ExtractSym1'
-- * 'SubstSym1'
-- * 'NFData1'
-- * 'Hashable1'
-- * 'Show1'
-- * 'PPrint1'
-- * 'AllSyms1'
-- * 'Eq1'
-- * 'SymEq1'
-- * 'SymOrd1'
-- * 'UnifiedSymEq1'
basicClasses1 :: [Name]
basicClasses1 :: [Name]
basicClasses1 =
  [ ''Mergeable1,
    ''EvalSym1,
    ''ExtractSym1,
    ''SubstSym1,
    ''NFData1,
    ''Hashable1,
    ''Show1,
    ''PPrint1,
    ''AllSyms1,
    ''Eq1,
    ''SymEq1,
    ''SymOrd1,
    ''UnifiedSymEq1
  ]

-- | @*1@ classes that can only be derived for GADT functors without existential
-- type variables.
--
-- This includes:
--
-- * 'Serial1'
-- * 'ToCon1'
-- * 'ToSym1'
noExistentialClasses1 :: [Name]
noExistentialClasses1 :: [Name]
noExistentialClasses1 = [''Serial1, ''ToCon1, ''ToSym1]

-- | @*1@ concrete ordered classes that can be derived for GADT functors that
--
-- * uses unified evaluation mode, or
-- * does not contain any symbolic variables.
--
-- This includes:
--
-- * 'Ord1'
-- * 'UnifiedSymOrd1'
concreteOrdClasses1 :: [Name]
concreteOrdClasses1 :: [Name]
concreteOrdClasses1 = [''Ord1, ''UnifiedSymOrd1]

-- | Basic classes for GADT functors.
--
-- This includes:
--
-- * 'Mergeable2'
-- * 'EvalSym2'
-- * 'ExtractSym2'
-- * 'SubstSym2'
-- * 'NFData2'
-- * 'Hashable2'
-- * 'Show2'
-- * 'PPrint2'
-- * 'AllSyms2'
-- * 'Eq2'
-- * 'SymEq2'
-- * 'SymOrd2'
-- * 'UnifiedSymEq2'
basicClasses2 :: [Name]
basicClasses2 :: [Name]
basicClasses2 =
  [ ''Mergeable2,
    ''EvalSym2,
    ''ExtractSym2,
    ''SubstSym2,
    ''NFData2,
    ''Hashable2,
    ''Show2,
    ''PPrint2,
    ''AllSyms2,
    ''Eq2,
    ''SymEq2,
    ''SymOrd2,
    ''UnifiedSymEq2
  ]

-- | @*2@ classes that can only be derived for GADT functors without existential
-- type variables.
--
-- This includes:
--
-- * 'Serial2'
-- * 'ToCon2'
-- * 'ToSym2'
noExistentialClasses2 :: [Name]
noExistentialClasses2 :: [Name]
noExistentialClasses2 = [''Serial2, ''ToCon2, ''ToSym2]

-- | @*2@ concrete ordered classes that can be derived for GADT functors that
--
-- * uses unified evaluation mode, or
-- * does not contain any symbolic variables.
--
-- This includes:
--
-- * 'Ord2'
-- * 'UnifiedSymOrd2'
concreteOrdClasses2 :: [Name]
concreteOrdClasses2 :: [Name]
concreteOrdClasses2 = [''Ord2, ''UnifiedSymOrd2]

-- | 'Show' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'Show'
-- * 'Show1'
-- * 'Show2'
showClasses :: [Name]
showClasses :: [Name]
showClasses = [''Show, ''Show1, ''Show2]

-- | 'PPrint' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'PPrint'
-- * 'PPrint1'
-- * 'PPrint2'
pprintClasses :: [Name]
pprintClasses :: [Name]
pprintClasses = [''PPrint, ''PPrint1, ''PPrint2]

-- | 'EvalSym' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'EvalSym'
-- * 'EvalSym1'
-- * 'EvalSym2'
evalSymClasses :: [Name]
evalSymClasses :: [Name]
evalSymClasses = [''EvalSym, ''EvalSym1, ''EvalSym2]

-- | 'ExtractSym' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'ExtractSym'
-- * 'ExtractSym1'
-- * 'ExtractSym2'
extractSymClasses :: [Name]
extractSymClasses :: [Name]
extractSymClasses = [''ExtractSym, ''ExtractSym1, ''ExtractSym2]

-- | 'SubstSym' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'SubstSym'
-- * 'SubstSym1'
-- * 'SubstSym2'
substSymClasses :: [Name]
substSymClasses :: [Name]
substSymClasses = [''SubstSym, ''SubstSym1, ''SubstSym2]

-- | 'AllSyms' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'AllSyms'
-- * 'AllSyms1'
-- * 'AllSyms2'
allSymsClasses :: [Name]
allSymsClasses :: [Name]
allSymsClasses = [''AllSyms, ''AllSyms1, ''AllSyms2]

-- | 'Eq' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'Eq'
-- * 'Eq1'
-- * 'Eq2'
eqClasses :: [Name]
eqClasses :: [Name]
eqClasses = [''Eq, ''Eq1, ''Eq2]

-- | 'SymEq' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'SymEq'
-- * 'SymEq1'
-- * 'SymEq2'
symEqClasses :: [Name]
symEqClasses :: [Name]
symEqClasses = [''SymEq, ''SymEq1, ''SymEq2]

-- | 'UnifiedSymEq' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'UnifiedSymEq'
-- * 'UnifiedSymEq1'
-- * 'UnifiedSymEq2'
unifiedSymEqClasses :: [Name]
unifiedSymEqClasses :: [Name]
unifiedSymEqClasses = [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2]

-- | 'Ord' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'Ord'
-- * 'Ord1'
-- * 'Ord2'
ordClasses :: [Name]
ordClasses :: [Name]
ordClasses = [''Ord, ''Ord1, ''Ord2]

-- | 'SymOrd' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'SymOrd'
-- * 'SymOrd1'
-- * 'SymOrd2'
symOrdClasses :: [Name]
symOrdClasses :: [Name]
symOrdClasses = [''SymOrd, ''SymOrd1, ''SymOrd2]

-- | 'UnifiedSymOrd' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'UnifiedSymOrd'
-- * 'UnifiedSymOrd1'
-- * 'UnifiedSymOrd2'
unifiedSymOrdClasses :: [Name]
unifiedSymOrdClasses :: [Name]
unifiedSymOrdClasses = [''UnifiedSymOrd, ''UnifiedSymOrd1, ''UnifiedSymOrd2]

-- | 'Mergeable' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'Mergeable'
-- * 'Mergeable1'
-- * 'Mergeable2'
-- * 'Mergeable3'
mergeableClasses :: [Name]
mergeableClasses :: [Name]
mergeableClasses = [''Mergeable, ''Mergeable1, ''Mergeable2, ''Mergeable3]

-- | 'NFData' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'NFData'
-- * 'NFData1'
-- * 'NFData2'
nfDataClasses :: [Name]
nfDataClasses :: [Name]
nfDataClasses = [''NFData, ''NFData1, ''NFData2]

-- | 'Hashable' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'Hashable'
-- * 'Hashable1'
-- * 'Hashable2'
hashableClasses :: [Name]
hashableClasses :: [Name]
hashableClasses = [''Hashable, ''Hashable1, ''Hashable2]

-- | 'ToSym' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'ToSym'
-- * 'ToSym1'
-- * 'ToSym2'
toSymClasses :: [Name]
toSymClasses :: [Name]
toSymClasses = [''ToSym, ''ToSym1, ''ToSym2]

-- | 'ToCon' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'ToCon'
-- * 'ToCon1'
-- * 'ToCon2'
toConClasses :: [Name]
toConClasses :: [Name]
toConClasses = [''ToCon, ''ToCon1, ''ToCon2]

-- | 'Serial' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'Serial'
-- * 'Serial1'
-- * 'Serial2'
serialClasses :: [Name]
serialClasses :: [Name]
serialClasses = [''Serial, ''Serial1, ''Serial2]

-- | 'SimpleMergeable' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'SimpleMergeable'
-- * 'SimpleMergeable1'
-- * 'SimpleMergeable2'
simpleMergeableClasses :: [Name]
simpleMergeableClasses :: [Name]
simpleMergeableClasses =
  [''SimpleMergeable, ''SimpleMergeable1, ''SimpleMergeable2]

-- | 'UnifiedSimpleMergeable' classes that can be derived for GADTs.
--
-- This includes:
--
-- * 'UnifiedSimpleMergeable'
-- * 'UnifiedSimpleMergeable1'
-- * 'UnifiedSimpleMergeable2'
unifiedSimpleMergeableClasses :: [Name]
unifiedSimpleMergeableClasses :: [Name]
unifiedSimpleMergeableClasses =
  [ ''UnifiedSimpleMergeable,
    ''UnifiedSimpleMergeable1,
    ''UnifiedSimpleMergeable2
  ]

clsArgNumArgs :: Name -> Int
clsArgNumArgs :: Name -> Int
clsArgNumArgs Name
cls =
  if
    | Name
cls Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
allClasses0 -> Int
0
    | Name
cls Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
allClasses1 -> Int
1
    | Name
cls Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
allClasses2 -> Int
2
    | Name
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Mergeable3 -> Int
3
    | Bool
otherwise -> String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"clsArgNumArgs: unknown class: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
cls

-- | Filter classes that accepts type constructors with exactly @n@ arguments.
filterExactNumArgs :: Int -> [Name] -> [Name]
filterExactNumArgs :: Int -> [Name] -> [Name]
filterExactNumArgs Int
n = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Name
cls -> Name -> Int
clsArgNumArgs Name
cls Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n)

-- | Filter classes that accepts type constructors with at most @n@ arguments.
filterLeqNumArgs :: Int -> [Name] -> [Name]
filterLeqNumArgs :: Int -> [Name] -> [Name]
filterLeqNumArgs Int
n = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Name
cls -> Name -> Int
clsArgNumArgs Name
cls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n)