DeriveEq.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      :   Grisette.Internal.TH.Derivation.DeriveEq
-- 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.DeriveEq
  ( deriveEq,
    deriveEq1,
    deriveEq2,
  )
where

import Data.Functor.Classes (Eq1 (liftEq), Eq2 (liftEq2))
import Grisette.Internal.TH.Derivation.BinaryOpCommon
  ( BinaryOpClassConfig
      ( BinaryOpClassConfig,
        binaryOpAllowSumType,
        binaryOpFieldConfigs,
        binaryOpInstanceNames
      ),
    BinaryOpFieldConfig
      ( BinaryOpFieldConfig,
        extraPatNames,
        fieldCombineFun,
        fieldDifferentExistentialFun,
        fieldFunExp,
        fieldFunNames,
        fieldLMatchResult,
        fieldRMatchResult,
        fieldResFun
      ),
    binaryOpAllowExistential,
    defaultFieldFunExp,
    genBinaryOpClass,
  )
import Grisette.Internal.TH.Derivation.Common (DeriveConfig)
import Language.Haskell.TH (Dec, Exp (ListE), Q)
import Language.Haskell.TH.Syntax (Name)

eqConfig :: BinaryOpClassConfig
eqConfig =
  BinaryOpClassConfig
    { binaryOpFieldConfigs =
        [ BinaryOpFieldConfig
            { extraPatNames = [],
              fieldResFun = \_ (lhs, rhs) f ->
                (,[]) <$> [|$(return f) $(return lhs) $(return rhs)|],
              fieldCombineFun = \_ lst ->
                (,[]) <$> [|and $(return $ ListE lst)|],
              fieldDifferentExistentialFun = const [|False|],
              fieldFunExp = defaultFieldFunExp ['(==), 'liftEq, 'liftEq2],
              fieldFunNames = ['(==), 'liftEq, 'liftEq2],
              fieldLMatchResult = [|False|],
              fieldRMatchResult = [|False|]
            }
        ],
      binaryOpInstanceNames = [''Eq, ''Eq1, ''Eq2],
      binaryOpAllowSumType = True,
      binaryOpAllowExistential = True
    }

-- | Derive 'Eq' instance for a data type.
deriveEq :: DeriveConfig -> Name -> Q [Dec]
deriveEq deriveConfig = genBinaryOpClass deriveConfig eqConfig 0

-- | Derive 'Eq1' instance for a data type.
deriveEq1 :: DeriveConfig -> Name -> Q [Dec]
deriveEq1 deriveConfig = genBinaryOpClass deriveConfig eqConfig 1

-- | Derive 'Eq2' instance for a data type.
deriveEq2 :: DeriveConfig -> Name -> Q [Dec]
deriveEq2 deriveConfig = genBinaryOpClass deriveConfig eqConfig 2