-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.TH.Single.Ord
-- Copyright   :  (C) 2023 Ryan Scott
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Defines a function to generate boilerplate Ord instances for singleton
-- types.
--
-----------------------------------------------------------------------------

module Data.Singletons.TH.Single.Ord (mkOrdInstanceForSingleton) where

import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Desugar
import Data.Singletons.TH.Names
import Data.Singletons.TH.Options
import Data.Singletons.TH.Promote.Type

-- Make a boilerplate Ord instance for a singleton type, e.g.,
--
-- @
-- instance Ord (SExample (z :: Example a)) where
--   compare _ _ = EQ
-- @
mkOrdInstanceForSingleton :: OptionsMonad q
                          => DType
                          -> Name
                          -- ^ The name of the data type
                          -> q DDec
mkOrdInstanceForSingleton :: forall (q :: * -> *). OptionsMonad q => DType -> Name -> q DDec
mkOrdInstanceForSingleton DType
data_ty Name
data_name = do
  Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
  Name
z <- String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"z"
  DType
data_ki <- DType -> q DType
forall (m :: * -> *). OptionsMonad m => DType -> m DType
promoteType DType
data_ty
  let sdata_name :: Name
sdata_name = Options -> Name -> Name
singledDataTypeName Options
opts Name
data_name
  DDec -> q DDec
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DDec -> q DDec) -> DDec -> q DDec
forall a b. (a -> b) -> a -> b
$ Maybe Overlap
-> Maybe [DTyVarBndrUnit] -> DCxt -> DType -> [DDec] -> DDec
DInstanceD Maybe Overlap
forall a. Maybe a
Nothing Maybe [DTyVarBndrUnit]
forall a. Maybe a
Nothing []
           (DType -> DType -> DType
DAppT (Name -> DType
DConT Name
ordName) (Name -> DType
DConT Name
sdata_name DType -> DType -> DType
`DAppT` DType -> DType -> DType
DSigT (Name -> DType
DVarT Name
z) DType
data_ki))
           [DLetDec -> DDec
DLetDec (DLetDec -> DDec) -> DLetDec -> DDec
forall a b. (a -> b) -> a -> b
$
            Name -> [DClause] -> DLetDec
DFunD Name
compareName
                  [[DPat] -> DExp -> DClause
DClause [DPat
DWildP, DPat
DWildP] (Name -> DExp
DConE Name
cmpEQName)]]