-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.TH.Deriving.Eq
-- Copyright   :  (C) 2020 Ryan Scott
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Implements deriving of Eq instances
--
----------------------------------------------------------------------------
module Data.Singletons.TH.Deriving.Eq (mkEqInstance) where

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

mkEqInstance :: DsMonad q => DerivDesc q
mkEqInstance :: forall (q :: * -> *). DsMonad q => DerivDesc q
mkEqInstance Maybe DCxt
mb_ctxt DType
ty (DataDecl DataFlavor
_ Name
_ [DTyVarBndrVis]
_ [DCon]
cons) = do
  let con_pairs :: [(DCon, DCon)]
con_pairs = [ (DCon
c1, DCon
c2) | DCon
c1 <- [DCon]
cons, DCon
c2 <- [DCon]
cons ]
  constraints <- Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
forall (q :: * -> *).
DsMonad q =>
Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
inferConstraintsDef Maybe DCxt
mb_ctxt (Name -> DType
DConT Name
eqName) DType
ty [DCon]
cons
  clauses <- if null cons
             then pure [DClause [DWildP, DWildP] (DConE trueName)]
             else traverse mkEqClause con_pairs
  pure (InstDecl { id_cxt = constraints
                 , id_name = eqName
                 , id_arg_tys = [ty]
                 , id_sigs  = mempty
                 , id_meths = [(equalsName, UFunction clauses)] })

mkEqClause :: Quasi q => (DCon, DCon) -> q DClause
mkEqClause :: forall (q :: * -> *). Quasi q => (DCon, DCon) -> q DClause
mkEqClause (DCon
c1, DCon
c2)
  | Name
lname Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
rname = do
      lnames <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
lNumArgs (String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"a")
      rnames <- replicateM lNumArgs (newUniqueName "b")
      let lpats = (Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
lnames
          rpats = (Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
rnames
          lvars = (Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
lnames
          rvars = (Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
rnames
      pure $ DClause
        [DConP lname [] lpats, DConP rname [] rpats]
        (andExp (zipWith (\DExp
l DExp
r -> DExp -> [DExp] -> DExp
foldExp (Name -> DExp
DVarE Name
equalsName) [DExp
l, DExp
r])
                         lvars rvars))
  | Bool
otherwise =
      DClause -> q DClause
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause
        [Name -> DCxt -> [DPat] -> DPat
DConP Name
lname [] (Int -> DPat -> [DPat]
forall a. Int -> a -> [a]
replicate Int
lNumArgs DPat
DWildP),
         Name -> DCxt -> [DPat] -> DPat
DConP Name
rname [] (Int -> DPat -> [DPat]
forall a. Int -> a -> [a]
replicate Int
rNumArgs DPat
DWildP)]
        (Name -> DExp
DConE Name
falseName)
  where
    andExp :: [DExp] -> DExp
    andExp :: [DExp] -> DExp
andExp []    = Name -> DExp
DConE Name
trueName
    andExp [DExp
one] = DExp
one
    andExp (DExp
h:[DExp]
t) = Name -> DExp
DVarE Name
andName DExp -> DExp -> DExp
`DAppE` DExp
h DExp -> DExp -> DExp
`DAppE` [DExp] -> DExp
andExp [DExp]
t

    (Name
lname, Int
lNumArgs) = DCon -> (Name, Int)
extractNameArgs DCon
c1
    (Name
rname, Int
rNumArgs) = DCon -> (Name, Int)
extractNameArgs DCon
c2