-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.Deriving.Ord
-- Copyright   :  (C) 2015 Richard Eisenberg
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Implements deriving of Ord instances
--
----------------------------------------------------------------------------

module Data.Singletons.Deriving.Ord ( mkOrdInstance ) where

import Language.Haskell.TH.Desugar
import Data.Singletons.Names
import Data.Singletons.Util
import Language.Haskell.TH.Syntax
import Data.Singletons.Deriving.Infer
import Data.Singletons.Deriving.Util
import Data.Singletons.Syntax

-- | Make a *non-singleton* Ord instance
mkOrdInstance :: DsMonad q => DerivDesc q
mkOrdInstance mb_ctxt ty (DataDecl _ _ cons) = do
  constraints <- inferConstraintsDef mb_ctxt (DConT ordName) ty cons
  compare_eq_clauses <- mapM mk_equal_clause cons
  let compare_noneq_clauses = map (uncurry mk_nonequal_clause)
                                  [ (con1, con2)
                                  | con1 <- zip cons [1..]
                                  , con2 <- zip cons [1..]
                                  , extractName (fst con1) /=
                                    extractName (fst con2) ]
      clauses | null cons = [mk_empty_clause]
              | otherwise = compare_eq_clauses ++ compare_noneq_clauses
  return (InstDecl { id_cxt = constraints
                   , id_name = ordName
                   , id_arg_tys = [ty]
                   , id_sigs  = mempty
                   , id_meths = [(compareName, UFunction clauses)] })

mk_equal_clause :: Quasi q => DCon -> q DClause
mk_equal_clause (DCon _tvbs _cxt name fields _rty) = do
  let tys = tysOfConFields fields
  a_names <- mapM (const $ newUniqueName "a") tys
  b_names <- mapM (const $ newUniqueName "b") tys
  let pat1 = DConP name (map DVarP a_names)
      pat2 = DConP name (map DVarP b_names)
  return $ DClause [pat1, pat2] (DVarE foldlName `DAppE`
                                 DVarE thenCmpName `DAppE`
                                 DConE cmpEQName `DAppE`
                                 mkListE (zipWith
                                          (\a b -> DVarE compareName `DAppE` DVarE a
                                                                     `DAppE` DVarE b)
                                          a_names b_names))

mk_nonequal_clause :: (DCon, Int) -> (DCon, Int) -> DClause
mk_nonequal_clause (DCon _tvbs1 _cxt1 name1 fields1 _rty1, n1)
                   (DCon _tvbs2 _cxt2 name2 fields2 _rty2, n2) =
  DClause [pat1, pat2] (case n1 `compare` n2 of
                          LT -> DConE cmpLTName
                          EQ -> DConE cmpEQName
                          GT -> DConE cmpGTName)
  where
    pat1 = DConP name1 (map (const DWildP) (tysOfConFields fields1))
    pat2 = DConP name2 (map (const DWildP) (tysOfConFields fields2))

-- A variant of mk_equal_clause tailored to empty datatypes
mk_empty_clause :: DClause
mk_empty_clause = DClause [DWildP, DWildP] (DConE cmpEQName)