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

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

-- |
-- Module      :   Grisette.Internal.TH.Derivation.DeriveToSym
-- 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.DeriveToSym
  ( deriveToSym,
    deriveToSym1,
    deriveToSym2,
  )
where

import Grisette.Internal.Internal.Decl.Core.Data.Class.ToSym
  ( ToSym (toSym),
    ToSym1 (liftToSym),
    ToSym2 (liftToSym2),
  )
import Grisette.Internal.TH.Derivation.Common (DeriveConfig)
import Grisette.Internal.TH.Derivation.ConvertOpCommon
  ( ConvertOpClassConfig
      ( ConvertOpClassConfig,
        convertFieldCombineFun,
        convertFieldFunExp,
        convertFieldResFun,
        convertOpInstanceNames,
        convertOpTarget
      ),
    convertOpFunNames,
    defaultFieldFunExp,
    genConvertOpClass,
  )
import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (S))
import Language.Haskell.TH (Dec, Name, Q, appE, conE)

toSymClassConfig :: ConvertOpClassConfig
toSymClassConfig :: ConvertOpClassConfig
toSymClassConfig =
  ConvertOpClassConfig
    { convertFieldResFun :: Exp -> Exp -> Q Exp
convertFieldResFun = \Exp
v Exp
f -> [|$(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
f) $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
v)|],
      convertFieldCombineFun :: Name -> [Exp] -> Q Exp
convertFieldCombineFun =
        \Name
f [Exp]
args -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
f) ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Exp]
args,
      convertFieldFunExp :: FieldFunExp
convertFieldFunExp = [Name] -> FieldFunExp
defaultFieldFunExp ['toSym, 'liftToSym, 'liftToSym2],
      convertOpTarget :: EvalModeTag
convertOpTarget = EvalModeTag
S,
      convertOpInstanceNames :: [Name]
convertOpInstanceNames = [''ToSym, ''ToSym1, ''ToSym2],
      convertOpFunNames :: [Name]
convertOpFunNames = ['toSym, 'liftToSym, 'liftToSym2]
    }

-- | Derive 'ToSym' instance for a data type.
deriveToSym :: DeriveConfig -> Name -> Q [Dec]
deriveToSym :: DeriveConfig -> Name -> Q [Dec]
deriveToSym DeriveConfig
deriveConfig = DeriveConfig -> ConvertOpClassConfig -> Int -> Name -> Q [Dec]
genConvertOpClass DeriveConfig
deriveConfig ConvertOpClassConfig
toSymClassConfig Int
0

-- | Derive 'ToSym1' instance for a data type.
deriveToSym1 :: DeriveConfig -> Name -> Q [Dec]
deriveToSym1 :: DeriveConfig -> Name -> Q [Dec]
deriveToSym1 DeriveConfig
deriveConfig =
  DeriveConfig -> ConvertOpClassConfig -> Int -> Name -> Q [Dec]
genConvertOpClass DeriveConfig
deriveConfig ConvertOpClassConfig
toSymClassConfig Int
1

-- | Derive 'ToSym2' instance for a data type.
deriveToSym2 :: DeriveConfig -> Name -> Q [Dec]
deriveToSym2 :: DeriveConfig -> Name -> Q [Dec]
deriveToSym2 DeriveConfig
deriveConfig =
  DeriveConfig -> ConvertOpClassConfig -> Int -> Name -> Q [Dec]
genConvertOpClass DeriveConfig
deriveConfig ConvertOpClassConfig
toSymClassConfig Int
2