{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :   Grisette.Internal.TH.GADT.DeriveToCon
-- 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.DeriveToCon
  ( deriveGADTToCon,
    deriveGADTToCon1,
    deriveGADTToCon2,
  )
where

import Grisette.Internal.Internal.Decl.Core.Data.Class.ToCon
  ( ToCon (toCon),
    ToCon1 (liftToCon),
    ToCon2 (liftToCon2),
  )
import Grisette.Internal.TH.GADT.Common (DeriveConfig)
import Grisette.Internal.TH.GADT.ConvertOpCommon
  ( ConvertOpClassConfig
      ( ConvertOpClassConfig,
        convertFieldCombineFun,
        convertFieldFunExp,
        convertFieldResFun,
        convertOpFunNames,
        convertOpInstanceNames,
        convertOpTarget
      ),
    defaultFieldFunExp,
    genConvertOpClass,
  )
import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C))
import Language.Haskell.TH (Dec, Name, Q, conE)

toConClassConfig :: ConvertOpClassConfig
toConClassConfig :: ConvertOpClassConfig
toConClassConfig =
  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
acc Q Exp
arg -> [|$(Q Exp
acc) <*> $Q Exp
arg|])
          [|return $(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 ['toCon, 'liftToCon, 'liftToCon2],
      convertOpTarget :: EvalModeTag
convertOpTarget = EvalModeTag
C,
      convertOpInstanceNames :: [Name]
convertOpInstanceNames = [''ToCon, ''ToCon1, ''ToCon2],
      convertOpFunNames :: [Name]
convertOpFunNames = ['toCon, 'liftToCon, 'liftToCon2]
    }

-- | Derive 'ToCon' instance for a GADT.
deriveGADTToCon :: DeriveConfig -> Name -> Q [Dec]
deriveGADTToCon :: DeriveConfig -> Name -> Q [Dec]
deriveGADTToCon DeriveConfig
deriveConfig = DeriveConfig -> ConvertOpClassConfig -> Int -> Name -> Q [Dec]
genConvertOpClass DeriveConfig
deriveConfig ConvertOpClassConfig
toConClassConfig Int
0

-- | Derive 'ToCon1' instance for a GADT.
deriveGADTToCon1 :: DeriveConfig -> Name -> Q [Dec]
deriveGADTToCon1 :: DeriveConfig -> Name -> Q [Dec]
deriveGADTToCon1 DeriveConfig
deriveConfig =
  DeriveConfig -> ConvertOpClassConfig -> Int -> Name -> Q [Dec]
genConvertOpClass DeriveConfig
deriveConfig ConvertOpClassConfig
toConClassConfig Int
1

-- | Derive 'ToCon2' instance for a GADT.
deriveGADTToCon2 :: DeriveConfig -> Name -> Q [Dec]
deriveGADTToCon2 :: DeriveConfig -> Name -> Q [Dec]
deriveGADTToCon2 DeriveConfig
deriveConfig =
  DeriveConfig -> ConvertOpClassConfig -> Int -> Name -> Q [Dec]
genConvertOpClass DeriveConfig
deriveConfig ConvertOpClassConfig
toConClassConfig Int
2