{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

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

-- |
-- Module      :   Grisette.Internal.TH.GADT.DeriveEvalSym
-- 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.DeriveEvalSym
  ( deriveGADTEvalSym,
    deriveGADTEvalSym1,
    deriveGADTEvalSym2,
  )
where

import Grisette.Internal.Core.Data.Class.EvalSym
  ( EvalSym (evalSym),
    EvalSym1 (liftEvalSym),
    EvalSym2 (liftEvalSym2),
  )
import Grisette.Internal.TH.GADT.UnaryOpCommon
  ( UnaryOpClassConfig
      ( UnaryOpClassConfig,
        unaryOpFieldConfig,
        unaryOpFunNames,
        unaryOpInstanceNames
      ),
    UnaryOpFieldConfig
      ( UnaryOpFieldConfig,
        extraPatNames,
        fieldCombineFun
      ),
    genUnaryOpClass,
  )
import Language.Haskell.TH
  ( Dec,
    Exp (AppE),
    Name,
    Q,
  )

genEvalSym' :: Int -> Name -> Q [Dec]
genEvalSym' :: Int -> Name -> Q [Dec]
genEvalSym' Int
n Name
typName = do
  UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass
    UnaryOpClassConfig
      { unaryOpFieldConfig :: UnaryOpFieldConfig
unaryOpFieldConfig =
          UnaryOpFieldConfig
            { extraPatNames :: [String]
extraPatNames = [String
"fillDefault", String
"model"],
              fieldCombineFun :: Exp -> [Exp] -> Q Exp
fieldCombineFun = \Exp
con [Exp]
exp -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE Exp
con [Exp]
exp
            },
        unaryOpInstanceNames :: [Name]
unaryOpInstanceNames =
          [''EvalSym, ''EvalSym1, ''EvalSym2],
        unaryOpFunNames :: [Name]
unaryOpFunNames =
          ['evalSym, 'liftEvalSym, 'liftEvalSym2]
      }
    Int
n
    Name
typName

-- | Derive 'EvalSym' instance for a GADT.
deriveGADTEvalSym :: Name -> Q [Dec]
deriveGADTEvalSym :: Name -> Q [Dec]
deriveGADTEvalSym = Int -> Name -> Q [Dec]
genEvalSym' Int
0

-- | Derive 'EvalSym1' instance for a GADT.
deriveGADTEvalSym1 :: Name -> Q [Dec]
deriveGADTEvalSym1 = Int -> Name -> Q [Dec]
genEvalSym' Int
1

-- | Derive 'EvalSym2' instance for a GADT.
deriveGADTEvalSym2 :: Name -> Q [Dec]
deriveGADTEvalSym2 :: Name -> Q [Dec]
deriveGADTEvalSym2 = Int -> Name -> Q [Dec]
genEvalSym' Int
2