{-# LANGUAGE TemplateHaskell #-}
{-# HLINT ignore "Unused LANGUAGE pragma" #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

-- |
-- Module      :   Grisette.Internal.TH.Derivation.DeriveExtractSym
-- 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.DeriveExtractSym
  ( deriveExtractSym,
    deriveExtractSym1,
    deriveExtractSym2,
  )
where

import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym
  ( ExtractSym (extractSymMaybe),
    ExtractSym1 (liftExtractSymMaybe),
    ExtractSym2 (liftExtractSymMaybe2),
  )
import Grisette.Internal.TH.Derivation.Common (DeriveConfig)
import Grisette.Internal.TH.Derivation.UnaryOpCommon
  ( UnaryOpClassConfig
      ( UnaryOpClassConfig,
        unaryOpAllowExistential,
        unaryOpConfigs,
        unaryOpContextNames,
        unaryOpExtraVars,
        unaryOpInstanceNames,
        unaryOpInstanceTypeFromConfig
      ),
    UnaryOpConfig (UnaryOpConfig),
    UnaryOpFieldConfig
      ( UnaryOpFieldConfig,
        extraLiftedPatNames,
        extraPatNames,
        fieldCombineFun,
        fieldFunExp,
        fieldResFun
      ),
    defaultFieldFunExp,
    defaultFieldResFun,
    defaultUnaryOpInstanceTypeFromConfig,
    genUnaryOpClass,
  )
import Language.Haskell.TH
  ( Dec,
    Exp (AppE, ListE, VarE),
    Name,
    Q,
  )

extractSymConfig :: UnaryOpClassConfig
extractSymConfig :: UnaryOpClassConfig
extractSymConfig =
  UnaryOpClassConfig
    { unaryOpConfigs :: [UnaryOpConfig]
unaryOpConfigs =
        [ UnaryOpFieldConfig -> [Name] -> UnaryOpConfig
forall config.
UnaryOpFunConfig config =>
config -> [Name] -> UnaryOpConfig
UnaryOpConfig
            UnaryOpFieldConfig
              { extraPatNames :: [String]
extraPatNames = [],
                extraLiftedPatNames :: Int -> [String]
extraLiftedPatNames = [String] -> Int -> [String]
forall a b. a -> b -> a
const [],
                fieldResFun :: ConstructorVariant
-> Name -> [Exp] -> Int -> Exp -> Exp -> Q (Exp, [Bool])
fieldResFun = ConstructorVariant
-> Name -> [Exp] -> Int -> Exp -> Exp -> Q (Exp, [Bool])
defaultFieldResFun,
                fieldCombineFun :: Int
-> Int
-> ConstructorVariant
-> Name
-> [Exp]
-> [Exp]
-> Q (Exp, [Bool])
fieldCombineFun = \Int
_ Int
_ ConstructorVariant
_ Name
_ [Exp]
_ [Exp]
exp ->
                  if [Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
exp
                    then (,[]) (Exp -> (Exp, [Bool])) -> Q Exp -> Q (Exp, [Bool])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|return mempty|]
                    else (Exp, [Bool]) -> Q (Exp, [Bool])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'mconcat) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [Exp]
exp, Bool
False Bool -> [Exp] -> [Bool]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Exp]
exp),
                fieldFunExp :: FieldFunExp
fieldFunExp =
                  [Name] -> FieldFunExp
defaultFieldFunExp
                    [ 'extractSymMaybe,
                      'liftExtractSymMaybe,
                      'liftExtractSymMaybe2
                    ]
              }
            [ 'extractSymMaybe,
              'liftExtractSymMaybe,
              'liftExtractSymMaybe2
            ]
        ],
      unaryOpInstanceNames :: [Name]
unaryOpInstanceNames =
        [''ExtractSym, ''ExtractSym1, ''ExtractSym2],
      unaryOpExtraVars :: DeriveConfig -> Q [(Type, Type)]
unaryOpExtraVars = Q [(Type, Type)] -> DeriveConfig -> Q [(Type, Type)]
forall a b. a -> b -> a
const (Q [(Type, Type)] -> DeriveConfig -> Q [(Type, Type)])
-> Q [(Type, Type)] -> DeriveConfig -> Q [(Type, Type)]
forall a b. (a -> b) -> a -> b
$ [(Type, Type)] -> Q [(Type, Type)]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [],
      unaryOpInstanceTypeFromConfig :: DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
unaryOpInstanceTypeFromConfig = DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
defaultUnaryOpInstanceTypeFromConfig,
      unaryOpAllowExistential :: Bool
unaryOpAllowExistential = Bool
True,
      unaryOpContextNames :: Maybe [Name]
unaryOpContextNames = Maybe [Name]
forall a. Maybe a
Nothing
    }

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

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

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