{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      :   Grisette.Internal.TH.Derivation.DeriveOrd
-- 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.DeriveOrd
  ( deriveOrd,
    deriveOrd1,
    deriveOrd2,
  )
where

import Data.Functor.Classes (Ord1 (liftCompare), Ord2 (liftCompare2))
import Grisette.Internal.TH.Derivation.BinaryOpCommon
  ( BinaryOpClassConfig
      ( BinaryOpClassConfig,
        binaryOpAllowSumType,
        binaryOpFieldConfigs,
        binaryOpInstanceNames
      ),
    BinaryOpFieldConfig
      ( BinaryOpFieldConfig,
        extraPatNames,
        fieldCombineFun,
        fieldDifferentExistentialFun,
        fieldFunExp,
        fieldFunNames,
        fieldLMatchResult,
        fieldRMatchResult,
        fieldResFun
      ),
    binaryOpAllowExistential,
    defaultFieldFunExp,
    genBinaryOpClass,
  )
import Grisette.Internal.TH.Derivation.Common (DeriveConfig)
import Language.Haskell.TH (Dec, Exp (ListE), Name, Q)

ordConfig :: BinaryOpClassConfig
ordConfig :: BinaryOpClassConfig
ordConfig =
  BinaryOpClassConfig
    { binaryOpFieldConfigs :: [BinaryOpFieldConfig]
binaryOpFieldConfigs =
        [ BinaryOpFieldConfig
            { extraPatNames :: [String]
extraPatNames = [],
              fieldResFun :: [Exp] -> (Exp, Exp) -> Exp -> Q (Exp, [Bool])
fieldResFun = \[Exp]
_ (Exp
lhs, Exp
rhs) Exp
f ->
                (,[]) (Exp -> (Exp, [Bool])) -> Q Exp -> Q (Exp, [Bool])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|$(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
lhs) $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
rhs)|],
              fieldCombineFun :: Name -> [Exp] -> Q (Exp, [Bool])
fieldCombineFun = \Name
_ [Exp]
lst ->
                (,[]) (Exp -> (Exp, [Bool])) -> Q Exp -> Q (Exp, [Bool])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [|mconcat $(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
ListE [Exp]
lst)|],
              fieldDifferentExistentialFun :: Exp -> Q Exp
fieldDifferentExistentialFun = Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return,
              fieldFunExp :: FieldFunExp
fieldFunExp =
                [Name] -> FieldFunExp
defaultFieldFunExp ['compare, 'liftCompare, 'liftCompare2],
              fieldFunNames :: [Name]
fieldFunNames = ['compare, 'liftCompare, 'liftCompare2],
              fieldLMatchResult :: Q Exp
fieldLMatchResult = [|LT|],
              fieldRMatchResult :: Q Exp
fieldRMatchResult = [|GT|]
            }
        ],
      binaryOpInstanceNames :: [Name]
binaryOpInstanceNames = [''Ord, ''Ord1, ''Ord2],
      binaryOpAllowSumType :: Bool
binaryOpAllowSumType = Bool
True,
      binaryOpAllowExistential :: Bool
binaryOpAllowExistential = Bool
True
    }

-- | Derive 'Ord' instance for a data type.
deriveOrd :: DeriveConfig -> Name -> Q [Dec]
deriveOrd :: DeriveConfig -> Name -> Q [Dec]
deriveOrd DeriveConfig
deriveConfig = DeriveConfig -> BinaryOpClassConfig -> Int -> Name -> Q [Dec]
genBinaryOpClass DeriveConfig
deriveConfig BinaryOpClassConfig
ordConfig Int
0

-- | Derive 'Ord1' instance for a data type.
deriveOrd1 :: DeriveConfig -> Name -> Q [Dec]
deriveOrd1 :: DeriveConfig -> Name -> Q [Dec]
deriveOrd1 DeriveConfig
deriveConfig = DeriveConfig -> BinaryOpClassConfig -> Int -> Name -> Q [Dec]
genBinaryOpClass DeriveConfig
deriveConfig BinaryOpClassConfig
ordConfig Int
1

-- | Derive 'Ord2' instance for a data type.
deriveOrd2 :: DeriveConfig -> Name -> Q [Dec]
deriveOrd2 :: DeriveConfig -> Name -> Q [Dec]
deriveOrd2 DeriveConfig
deriveConfig = DeriveConfig -> BinaryOpClassConfig -> Int -> Name -> Q [Dec]
genBinaryOpClass DeriveConfig
deriveConfig BinaryOpClassConfig
ordConfig Int
2