{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Unused LANGUAGE pragma" #-}

-- |
-- Module      :   Grisette.Internal.TH.Derivation.DeriveUnifiedSymEq
-- 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.DeriveUnifiedSymEq
  ( deriveUnifiedSymEq,
    deriveUnifiedSymEq1,
    deriveUnifiedSymEq2,
  )
where

import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSymEq
  ( UnifiedSymEq (withBaseSymEq),
    UnifiedSymEq1 (withBaseSymEq1),
    UnifiedSymEq2 (withBaseSymEq2),
  )
import Grisette.Internal.TH.Derivation.Common (DeriveConfig (evalModeConfig))
import Grisette.Internal.TH.Derivation.UnaryOpCommon
  ( UnaryOpClassConfig
      ( UnaryOpClassConfig,
        unaryOpAllowExistential,
        unaryOpConfigs,
        unaryOpContextNames,
        unaryOpExtraVars,
        unaryOpInstanceNames,
        unaryOpInstanceTypeFromConfig
      ),
    UnaryOpConfig (UnaryOpConfig),
    genUnaryOpClass,
  )
import Grisette.Internal.TH.Derivation.UnifiedOpCommon
  ( UnaryOpUnifiedConfig (UnaryOpUnifiedConfig, unifiedFun),
    defaultUnaryOpUnifiedFun,
  )
import Grisette.Internal.Unified.EvalModeTag (EvalModeTag)
import Language.Haskell.TH
  ( Dec,
    Name,
    Q,
    Type (ConT, VarT),
    appT,
    conT,
    newName,
  )

unifiedSymEqConfig :: UnaryOpClassConfig
unifiedSymEqConfig :: UnaryOpClassConfig
unifiedSymEqConfig =
  UnaryOpClassConfig
    { unaryOpConfigs :: [UnaryOpConfig]
unaryOpConfigs =
        [ UnaryOpUnifiedConfig -> [Name] -> UnaryOpConfig
forall config.
UnaryOpFunConfig config =>
config -> [Name] -> UnaryOpConfig
UnaryOpConfig
            UnaryOpUnifiedConfig
              { unifiedFun :: Type -> (Type, Type) -> Q (Maybe Exp)
unifiedFun =
                  [Name] -> Type -> (Type, Type) -> Q (Maybe Exp)
defaultUnaryOpUnifiedFun
                    ['withBaseSymEq, 'withBaseSymEq1, 'withBaseSymEq2]
              }
            ['withBaseSymEq, 'withBaseSymEq1, 'withBaseSymEq2]
        ],
      unaryOpInstanceNames :: [Name]
unaryOpInstanceNames = [''UnifiedSymEq, ''UnifiedSymEq1, ''UnifiedSymEq2],
      unaryOpExtraVars :: DeriveConfig -> Q [(Type, Type)]
unaryOpExtraVars = \DeriveConfig
config -> do
        let modeConfigs :: [(Int, EvalModeConfig)]
modeConfigs = DeriveConfig -> [(Int, EvalModeConfig)]
evalModeConfig DeriveConfig
config
        case [(Int, EvalModeConfig)]
modeConfigs of
          [] -> do
            nm <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mode"
            return [(VarT nm, ConT ''EvalModeTag)]
          [(Int, EvalModeConfig)
_] -> [(Type, Type)] -> Q [(Type, Type)]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          [(Int, EvalModeConfig)]
_ -> String -> Q [(Type, Type)]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"UnifiedSymEq does not support multiple evaluation modes",
      unaryOpInstanceTypeFromConfig :: DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
unaryOpInstanceTypeFromConfig =
        \DeriveConfig
config [(Type, Type)]
newModeVars [(Type, Type)]
keptNewVars Name
con -> do
          let modeConfigs :: [(Int, EvalModeConfig)]
modeConfigs = DeriveConfig -> [(Int, EvalModeConfig)]
evalModeConfig DeriveConfig
config
          modeVar <- case [(Int, EvalModeConfig)]
modeConfigs of
            [] -> (Type, Type) -> Q (Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type, Type) -> Q (Type, Type)) -> (Type, Type) -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$ [(Type, Type)] -> (Type, Type)
forall a. HasCallStack => [a] -> a
head [(Type, Type)]
newModeVars
            [(Int
i, EvalModeConfig
_)] -> do
              if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [(Type, Type)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Type)]
keptNewVars
                then String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"UnifiedSymEq reference to a non-existent mode variable"
                else (Type, Type) -> Q (Type, Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type, Type) -> Q (Type, Type)) -> (Type, Type) -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$ [(Type, Type)]
keptNewVars [(Type, Type)] -> Int -> (Type, Type)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
            [(Int, EvalModeConfig)]
_ -> String -> Q (Type, Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"UnifiedSymEq does not support multiple evaluation modes"
          appT (conT con) (return $ fst modeVar),
      unaryOpAllowExistential :: Bool
unaryOpAllowExistential = Bool
True,
      unaryOpContextNames :: Maybe [Name]
unaryOpContextNames = Maybe [Name]
forall a. Maybe a
Nothing
    }

-- | Derive 'UnifiedSymEq' instance for a data type.
deriveUnifiedSymEq :: DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymEq :: DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymEq DeriveConfig
deriveConfig =
  DeriveConfig -> UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass DeriveConfig
deriveConfig UnaryOpClassConfig
unifiedSymEqConfig Int
0

-- | Derive 'UnifiedSymEq1' instance for a data type.
deriveUnifiedSymEq1 :: DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymEq1 :: DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymEq1 DeriveConfig
deriveConfig =
  DeriveConfig -> UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass DeriveConfig
deriveConfig UnaryOpClassConfig
unifiedSymEqConfig Int
1

-- | Derive 'UnifiedSymEq2' instance for a data type.
deriveUnifiedSymEq2 :: DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymEq2 :: DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSymEq2 DeriveConfig
deriveConfig =
  DeriveConfig -> UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass DeriveConfig
deriveConfig UnaryOpClassConfig
unifiedSymEqConfig Int
2