content: {-# LANGUAGE TemplateHaskell #-}
  {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
  
  {-# HLINT ignore "Unused LANGUAGE pragma" #-}
  
  -- |
  -- Module      :   Grisette.Internal.TH.Derivation.DeriveSubstSym
  -- 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.DeriveSubstSym
    ( deriveSubstSym,
      deriveSubstSym1,
      deriveSubstSym2,
    )
  where
  
  import Grisette.Internal.Internal.Decl.Core.Data.Class.SubstSym
    ( SubstSym (substSym),
      SubstSym1 (liftSubstSym),
      SubstSym2 (liftSubstSym2),
    )
  import Grisette.Internal.TH.Derivation.Common (DeriveConfig)
  import Grisette.Internal.TH.Derivation.UnaryOpCommon
    ( UnaryOpClassConfig
        ( UnaryOpClassConfig,
          unaryOpAllowExistential,
          unaryOpConfigs,
          unaryOpContextNames,
          unaryOpExtraVars,
          unaryOpInstanceNames,
          unaryOpInstanceTypeFromConfig
        ),
      UnaryOpConfig (UnaryOpConfig),
      UnaryOpFieldConfig
        ( UnaryOpFieldConfig,
          extraLiftedPatNames,
          extraPatNames,
          fieldCombineFun,
          fieldFunExp,
          fieldResFun
        ),
      defaultFieldFunExp,
      defaultFieldResFun,
      defaultUnaryOpInstanceTypeFromConfig,
      genUnaryOpClass,
    )
  import Language.Haskell.TH (Dec, Exp (AppE, ConE), Name)
  import Language.Haskell.TH.Syntax (Q)
  
  substSymConfig :: UnaryOpClassConfig
  substSymConfig =
    UnaryOpClassConfig
      { unaryOpConfigs =
          [ UnaryOpConfig
              UnaryOpFieldConfig
                { extraPatNames = ["symbol", "newVal"],
                  extraLiftedPatNames = const [],
                  fieldResFun = defaultFieldResFun,
                  fieldCombineFun = \_ _ _ con extraPat exp ->
                    return (foldl AppE (ConE con) exp, False <$ extraPat),
                  fieldFunExp =
                    defaultFieldFunExp
                      ['substSym, 'liftSubstSym, 'liftSubstSym2]
                }
              ['substSym, 'liftSubstSym, 'liftSubstSym2]
          ],
        unaryOpInstanceNames =
          [''SubstSym, ''SubstSym1, ''SubstSym2],
        unaryOpExtraVars = const $ return [],
        unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,
        unaryOpAllowExistential = True,
        unaryOpContextNames = Nothing
      }
  
  -- | Derive 'SubstSym' instance for a data type.
  deriveSubstSym :: DeriveConfig -> Name -> Q [Dec]
  deriveSubstSym deriveConfig = genUnaryOpClass deriveConfig substSymConfig 0
  
  -- | Derive 'SubstSym1' instance for a data type.
  deriveSubstSym1 :: DeriveConfig -> Name -> Q [Dec]
  deriveSubstSym1 deriveConfig = genUnaryOpClass deriveConfig substSymConfig 1
  
  -- | Derive 'SubstSym2' instance for a data type.
  deriveSubstSym2 :: DeriveConfig -> Name -> Q [Dec]
  deriveSubstSym2 deriveConfig = genUnaryOpClass deriveConfig substSymConfig 2
  