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

-- |
-- Module      :   Grisette.Internal.TH.GADT.DeriveGADT
-- 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.GADT.DeriveGADT
  ( deriveGADT,
    deriveGADTWith,
    allClasses0,
    allClasses01,
    allClasses012,
    basicClasses0,
    noExistentialClasses0,
    ordClasses0,
    basicClasses1,
    noExistentialClasses1,
    ordClasses1,
    basicClasses2,
    noExistentialClasses2,
    ordClasses2,
  )
where

import Control.Arrow (Arrow (second))
import Control.DeepSeq (NFData, NFData1, NFData2)
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 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.GADT.Common
  ( DeriveConfig
      ( evalModeConfig,
        needExtraMergeableUnderEvalMode,
        needExtraMergeableWithConcretizedEvalMode
      ),
    EvalModeConfig (EvalModeConstraints, EvalModeSpecified),
  )
import Grisette.Internal.TH.GADT.DeriveAllSyms
  ( deriveGADTAllSyms,
    deriveGADTAllSyms1,
    deriveGADTAllSyms2,
  )
import Grisette.Internal.TH.GADT.DeriveEq
  ( deriveGADTEq,
    deriveGADTEq1,
    deriveGADTEq2,
  )
import Grisette.Internal.TH.GADT.DeriveEvalSym
  ( deriveGADTEvalSym,
    deriveGADTEvalSym1,
    deriveGADTEvalSym2,
  )
import Grisette.Internal.TH.GADT.DeriveExtractSym
  ( deriveGADTExtractSym,
    deriveGADTExtractSym1,
    deriveGADTExtractSym2,
  )
import Grisette.Internal.TH.GADT.DeriveHashable
  ( deriveGADTHashable,
    deriveGADTHashable1,
    deriveGADTHashable2,
  )
import Grisette.Internal.TH.GADT.DeriveMergeable
  ( genMergeable,
    genMergeable',
    genMergeableAndGetMergingInfoResult,
    genMergeableNoExistential,
  )
import Grisette.Internal.TH.GADT.DeriveNFData
  ( deriveGADTNFData,
    deriveGADTNFData1,
    deriveGADTNFData2,
  )
import Grisette.Internal.TH.GADT.DeriveOrd
  ( deriveGADTOrd,
    deriveGADTOrd1,
    deriveGADTOrd2,
  )
import Grisette.Internal.TH.GADT.DerivePPrint
  ( deriveGADTPPrint,
    deriveGADTPPrint1,
    deriveGADTPPrint2,
  )
import Grisette.Internal.TH.GADT.DeriveSerial
  ( deriveGADTSerial,
    deriveGADTSerial1,
    deriveGADTSerial2,
  )
import Grisette.Internal.TH.GADT.DeriveShow
  ( deriveGADTShow,
    deriveGADTShow1,
    deriveGADTShow2,
  )
import Grisette.Internal.TH.GADT.DeriveSimpleMergeable
  ( deriveGADTSimpleMergeable,
    deriveGADTSimpleMergeable1,
    deriveGADTSimpleMergeable2,
  )
import Grisette.Internal.TH.GADT.DeriveSubstSym
  ( deriveGADTSubstSym,
    deriveGADTSubstSym1,
    deriveGADTSubstSym2,
  )
import Grisette.Internal.TH.GADT.DeriveSymEq
  ( deriveGADTSymEq,
    deriveGADTSymEq1,
    deriveGADTSymEq2,
  )
import Grisette.Internal.TH.GADT.DeriveSymOrd
  ( deriveGADTSymOrd,
    deriveGADTSymOrd1,
    deriveGADTSymOrd2,
  )
import Grisette.Internal.TH.GADT.DeriveToCon
  ( deriveGADTToCon,
    deriveGADTToCon1,
    deriveGADTToCon2,
  )
import Grisette.Internal.TH.GADT.DeriveToSym
  ( deriveGADTToSym,
    deriveGADTToSym1,
    deriveGADTToSym2,
  )
import Grisette.Internal.TH.GADT.DeriveUnifiedSimpleMergeable
  ( deriveGADTUnifiedSimpleMergeable,
    deriveGADTUnifiedSimpleMergeable1,
    deriveGADTUnifiedSimpleMergeable2,
  )
import Grisette.Internal.TH.GADT.DeriveUnifiedSymEq
  ( deriveGADTUnifiedSymEq,
    deriveGADTUnifiedSymEq1,
    deriveGADTUnifiedSymEq2,
  )
import Grisette.Internal.TH.GADT.DeriveUnifiedSymOrd
  ( deriveGADTUnifiedSymOrd,
    deriveGADTUnifiedSymOrd1,
    deriveGADTUnifiedSymOrd2,
  )
import Grisette.Internal.TH.Util (dataTypeHasExistential)
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]
deriveGADTEvalSym),
      (''EvalSym1, DeriveConfig -> Name -> Q [Dec]
deriveGADTEvalSym1),
      (''EvalSym2, DeriveConfig -> Name -> Q [Dec]
deriveGADTEvalSym2),
      (''ExtractSym, DeriveConfig -> Name -> Q [Dec]
deriveGADTExtractSym),
      (''ExtractSym1, DeriveConfig -> Name -> Q [Dec]
deriveGADTExtractSym1),
      (''ExtractSym2, DeriveConfig -> Name -> Q [Dec]
deriveGADTExtractSym2),
      (''SubstSym, DeriveConfig -> Name -> Q [Dec]
deriveGADTSubstSym),
      (''SubstSym1, DeriveConfig -> Name -> Q [Dec]
deriveGADTSubstSym1),
      (''SubstSym2, DeriveConfig -> Name -> Q [Dec]
deriveGADTSubstSym2),
      (''NFData, DeriveConfig -> Name -> Q [Dec]
deriveGADTNFData),
      (''NFData1, DeriveConfig -> Name -> Q [Dec]
deriveGADTNFData1),
      (''NFData2, DeriveConfig -> Name -> Q [Dec]
deriveGADTNFData2),
      (''Hashable, DeriveConfig -> Name -> Q [Dec]
deriveGADTHashable),
      (''Hashable1, DeriveConfig -> Name -> Q [Dec]
deriveGADTHashable1),
      (''Hashable2, DeriveConfig -> Name -> Q [Dec]
deriveGADTHashable2),
      (''Show, DeriveConfig -> Name -> Q [Dec]
deriveGADTShow),
      (''Show1, DeriveConfig -> Name -> Q [Dec]
deriveGADTShow1),
      (''Show2, DeriveConfig -> Name -> Q [Dec]
deriveGADTShow2),
      (''PPrint, DeriveConfig -> Name -> Q [Dec]
deriveGADTPPrint),
      (''PPrint1, DeriveConfig -> Name -> Q [Dec]
deriveGADTPPrint1),
      (''PPrint2, DeriveConfig -> Name -> Q [Dec]
deriveGADTPPrint2),
      (''AllSyms, DeriveConfig -> Name -> Q [Dec]
deriveGADTAllSyms),
      (''AllSyms1, DeriveConfig -> Name -> Q [Dec]
deriveGADTAllSyms1),
      (''AllSyms2, DeriveConfig -> Name -> Q [Dec]
deriveGADTAllSyms2),
      (''Eq, DeriveConfig -> Name -> Q [Dec]
deriveGADTEq),
      (''Eq1, DeriveConfig -> Name -> Q [Dec]
deriveGADTEq1),
      (''Eq2, DeriveConfig -> Name -> Q [Dec]
deriveGADTEq2),
      (''Ord, DeriveConfig -> Name -> Q [Dec]
deriveGADTOrd),
      (''Ord1, DeriveConfig -> Name -> Q [Dec]
deriveGADTOrd1),
      (''Ord2, DeriveConfig -> Name -> Q [Dec]
deriveGADTOrd2),
      (''SymOrd, DeriveConfig -> Name -> Q [Dec]
deriveGADTSymOrd),
      (''SymOrd1, DeriveConfig -> Name -> Q [Dec]
deriveGADTSymOrd1),
      (''SymOrd2, DeriveConfig -> Name -> Q [Dec]
deriveGADTSymOrd2),
      (''SymEq, DeriveConfig -> Name -> Q [Dec]
deriveGADTSymEq),
      (''SymEq1, DeriveConfig -> Name -> Q [Dec]
deriveGADTSymEq1),
      (''SymEq2, DeriveConfig -> Name -> Q [Dec]
deriveGADTSymEq2),
      (''UnifiedSymEq, DeriveConfig -> Name -> Q [Dec]
deriveGADTUnifiedSymEq),
      (''UnifiedSymEq1, DeriveConfig -> Name -> Q [Dec]
deriveGADTUnifiedSymEq1),
      (''UnifiedSymEq2, DeriveConfig -> Name -> Q [Dec]
deriveGADTUnifiedSymEq2),
      (''UnifiedSymOrd, DeriveConfig -> Name -> Q [Dec]
deriveGADTUnifiedSymOrd),
      (''UnifiedSymOrd1, DeriveConfig -> Name -> Q [Dec]
deriveGADTUnifiedSymOrd1),
      (''UnifiedSymOrd2, DeriveConfig -> Name -> Q [Dec]
deriveGADTUnifiedSymOrd2),
      (''ToSym, DeriveConfig -> Name -> Q [Dec]
deriveGADTToSym),
      (''ToSym1, DeriveConfig -> Name -> Q [Dec]
deriveGADTToSym1),
      (''ToSym2, DeriveConfig -> Name -> Q [Dec]
deriveGADTToSym2),
      (''ToCon, DeriveConfig -> Name -> Q [Dec]
deriveGADTToCon),
      (''ToCon1, DeriveConfig -> Name -> Q [Dec]
deriveGADTToCon1),
      (''ToCon2, DeriveConfig -> Name -> Q [Dec]
deriveGADTToCon2),
      (''Serial, DeriveConfig -> Name -> Q [Dec]
deriveGADTSerial),
      (''Serial1, DeriveConfig -> Name -> Q [Dec]
deriveGADTSerial1),
      (''Serial2, DeriveConfig -> Name -> Q [Dec]
deriveGADTSerial2),
      (''SimpleMergeable, DeriveConfig -> Name -> Q [Dec]
deriveGADTSimpleMergeable),
      (''SimpleMergeable1, DeriveConfig -> Name -> Q [Dec]
deriveGADTSimpleMergeable1),
      (''SimpleMergeable2, DeriveConfig -> Name -> Q [Dec]
deriveGADTSimpleMergeable2),
      (''UnifiedSimpleMergeable, DeriveConfig -> Name -> Q [Dec]
deriveGADTUnifiedSimpleMergeable),
      (''UnifiedSimpleMergeable1, DeriveConfig -> Name -> Q [Dec]
deriveGADTUnifiedSimpleMergeable1),
      (''UnifiedSimpleMergeable2, DeriveConfig -> Name -> Q [Dec]
deriveGADTUnifiedSimpleMergeable2)
    ]

deriveSingleGADT :: DeriveConfig -> Name -> Name -> Q [Dec]
deriveSingleGADT :: DeriveConfig -> Name -> Name -> Q [Dec]
deriveSingleGADT 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

deriveGADTWith' :: DeriveConfig -> Name -> [Name] -> Q [Dec]
deriveGADTWith' :: DeriveConfig -> Name -> [Name] -> Q [Dec]
deriveGADTWith' 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
  [[Dec]]
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]
deriveSingleGADT DeriveConfig
deriveConfig Name
typName) [Name]
ns
  [Dec]
decMergeables <- [Int] -> Q [Dec]
deriveMergeables [Int]
ms
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decMergeables
  where
    configWithOutExtraMergeable :: DeriveConfig
    configWithOutExtraMergeable :: DeriveConfig
configWithOutExtraMergeable =
      DeriveConfig
deriveConfig {needExtraMergeableUnderEvalMode = False}
    deriveMergeables :: [Int] -> Q [Dec]
    deriveMergeables :: [Int] -> Q [Dec]
deriveMergeables [] = [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    deriveMergeables [Int
n] = DeriveConfig -> Name -> Int -> Q [Dec]
genMergeable DeriveConfig
configWithOutExtraMergeable Name
typName Int
n
    deriveMergeables (Int
n : [Int]
ns) = do
      Bool
hasExistential <- Name -> Q Bool
dataTypeHasExistential Name
typName
      if Bool
hasExistential
        then do
          (MergingInfoResult
info, [Dec]
dn) <-
            DeriveConfig -> Name -> Int -> Q (MergingInfoResult, [Dec])
genMergeableAndGetMergingInfoResult
              DeriveConfig
configWithOutExtraMergeable
              Name
typName
              Int
n
          [(Name, [Dec])]
dns <-
            (Int -> Q (Name, [Dec])) -> [Int] -> Q [(Name, [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 (DeriveConfig -> MergingInfoResult -> Name -> Int -> Q (Name, [Dec])
genMergeable' DeriveConfig
configWithOutExtraMergeable MergingInfoResult
info Name
typName) [Int]
ns
          [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
dn [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ ((Name, [Dec]) -> [Dec]) -> [(Name, [Dec])] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [Dec]) -> [Dec]
forall a b. (a, b) -> b
snd [(Name, [Dec])]
dns
        else do
          [[Dec]]
dns <-
            (Int -> Q [Dec]) -> [Int] -> 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
              (DeriveConfig -> Name -> Int -> Q [Dec]
genMergeableNoExistential DeriveConfig
configWithOutExtraMergeable Name
typName)
              (Int
n Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ns)
          [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
dns
    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 GADT with the given name.
--
-- Support the following classes.
--
-- * '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'
--
-- Note that the following type classes cannot be derived for GADTs with
-- existential type variables.
--
-- * 'Eq1'
-- * 'Eq2'
-- * 'SymEq1'
-- * 'SymEq2'
-- * 'Ord1'
-- * 'Ord2'
-- * 'SymOrd1'
-- * 'SymOrd2'
deriveGADTWith :: DeriveConfig -> [Name] -> [Name] -> Q [Dec]
deriveGADTWith :: DeriveConfig -> [Name] -> [Name] -> Q [Dec]
deriveGADTWith 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]
deriveGADTWith' DeriveConfig
deriveConfig Name
typeName [Name]
classNameList)
      [Name]
typeNames

-- | Derive the specified classes for a GADT with the given name.
--
-- See 'deriveGADTWith' for more details.
deriveGADT :: [Name] -> [Name] -> Q [Dec]
deriveGADT :: [Name] -> [Name] -> Q [Dec]
deriveGADT = DeriveConfig -> [Name] -> [Name] -> Q [Dec]
deriveGADTWith 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]
ordClasses0 [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]
ordClasses1 [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]
ordClasses2 [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
noExistentialClasses2

-- | All the classes that can be derived for GADTfunctors.
--
-- 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'
-- * 'ToCon'
-- * 'ToSym'
noExistentialClasses0 :: [Name]
noExistentialClasses0 :: [Name]
noExistentialClasses0 = [''Serial, ''ToCon, ''ToSym]

-- | 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'
ordClasses0 :: [Name]
ordClasses0 :: [Name]
ordClasses0 = [''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'
ordClasses1 :: [Name]
ordClasses1 :: [Name]
ordClasses1 = [''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'
ordClasses2 :: [Name]
ordClasses2 :: [Name]
ordClasses2 = [''Ord2, ''UnifiedSymOrd2]