DeriveUnifiedSimpleMergeable.hs

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

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

-- |
-- Module      :   Grisette.Internal.TH.Derivation.DeriveUnifiedSimpleMergeable
-- 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.DeriveUnifiedSimpleMergeable
  ( deriveUnifiedSimpleMergeable,
    deriveUnifiedSimpleMergeable1,
    deriveUnifiedSimpleMergeable2,
  )
where

import Grisette.Internal.Internal.Decl.Unified.Class.UnifiedSimpleMergeable
  ( UnifiedSimpleMergeable (withBaseSimpleMergeable),
    UnifiedSimpleMergeable1 (withBaseSimpleMergeable1),
    UnifiedSimpleMergeable2 (withBaseSimpleMergeable2),
  )
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,
  )

unifiedSimpleMergeableConfig :: UnaryOpClassConfig
unifiedSimpleMergeableConfig =
  UnaryOpClassConfig
    { unaryOpConfigs =
        [ UnaryOpConfig
            UnaryOpUnifiedConfig
              { unifiedFun =
                  defaultUnaryOpUnifiedFun
                    [ 'withBaseSimpleMergeable,
                      'withBaseSimpleMergeable1,
                      'withBaseSimpleMergeable2
                    ]
              }
            [ 'withBaseSimpleMergeable,
              'withBaseSimpleMergeable1,
              'withBaseSimpleMergeable2
            ]
        ],
      unaryOpInstanceNames =
        [ ''UnifiedSimpleMergeable,
          ''UnifiedSimpleMergeable1,
          ''UnifiedSimpleMergeable2
        ],
      unaryOpExtraVars = \config -> do
        let modeConfigs = evalModeConfig config
        case modeConfigs of
          [] -> do
            nm <- newName "mode"
            return [(VarT nm, ConT ''EvalModeTag)]
          [_] -> return []
          _ -> fail "UnifiedSimpleMergeable does not support multiple evaluation modes",
      unaryOpInstanceTypeFromConfig =
        \config newModeVars keptNewVars con -> do
          let modeConfigs = evalModeConfig config
          modeVar <- case modeConfigs of
            [] -> return $ head newModeVars
            [(i, _)] -> do
              if i >= length keptNewVars
                then fail "UnifiedSimpleMergeable reference to a non-existent mode variable"
                else return $ keptNewVars !! i
            _ -> fail "UnifiedSimpleMergeable does not support multiple evaluation modes"
          appT (conT con) (return $ fst modeVar),
      unaryOpAllowExistential = True,
      unaryOpContextNames = Nothing
    }

-- | Derive 'UnifiedSimpleMergeable' instance for a data type.
deriveUnifiedSimpleMergeable :: DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSimpleMergeable deriveConfig =
  genUnaryOpClass deriveConfig unifiedSimpleMergeableConfig 0

-- | Derive 'UnifiedSimpleMergeable1' instance for a data type.
deriveUnifiedSimpleMergeable1 :: DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSimpleMergeable1 deriveConfig =
  genUnaryOpClass deriveConfig unifiedSimpleMergeableConfig 1

-- | Derive 'UnifiedSimpleMergeable2' instance for a data type.
deriveUnifiedSimpleMergeable2 :: DeriveConfig -> Name -> Q [Dec]
deriveUnifiedSimpleMergeable2 deriveConfig =
  genUnaryOpClass deriveConfig unifiedSimpleMergeableConfig 2