{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Multi.Derive.Ordering
-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
-- License     :  BSD3
-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Automatically derive instances of @OrdHF@.
--
--------------------------------------------------------------------------------
module Data.Comp.Multi.Derive.Ordering
    (
     OrdHF(..),
     makeOrdHF
    ) where

import Data.Comp.Derive.Utils
import Data.Comp.Multi.Ordering
import Data.List
import Data.Maybe
import Language.Haskell.TH hiding (Cxt)

compList :: [Ordering] -> Ordering
compList :: [Ordering] -> Ordering
compList = Ordering -> Maybe Ordering -> Ordering
forall a. a -> Maybe a -> a
fromMaybe Ordering
EQ (Maybe Ordering -> Ordering)
-> ([Ordering] -> Maybe Ordering) -> [Ordering] -> Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ordering -> Bool) -> [Ordering] -> Maybe Ordering
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
EQ)

{-| Derive an instance of 'OrdHF' for a type constructor of any parametric
  kind taking at least three arguments. -}
makeOrdHF :: Name -> Q [Dec]
makeOrdHF :: Name -> Q [Dec]
makeOrdHF fname :: Name
fname = do
  Just (DataInfo _ name :: Name
name args :: [TyVarBndr]
args constrs :: [Con]
constrs _) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
  let args' :: [TyVarBndr]
args' = [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
args
  -- covariant argument
  let Type
coArg :: Type = Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> Name
tyVarBndrName (TyVarBndr -> Name) -> TyVarBndr -> Name
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
args'
  let argNames :: [Type]
argNames = (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarBndrName) ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
args')
  let complType :: Type
complType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) [Type]
argNames
  let classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''OrdHF) Type
complType
  [(Name, [Type], Maybe Type)]
constrs' :: [(Name,[Type],Maybe Type)] <- (Con -> Q (Name, [Type], Maybe Type))
-> [Con] -> Q [(Name, [Type], Maybe Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q (Name, [Type], Maybe Type)
normalConExp [Con]
constrs
  Dec
compareHFDecl <- Name -> [ClauseQ] -> DecQ
funD 'compareHF (Type -> [(Name, [Type], Maybe Type)] -> [ClauseQ]
compareHFClauses Type
coArg [(Name, [Type], Maybe Type)]
constrs')
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Type] -> Type -> [Dec] -> Dec
mkInstanceD [] Type
classType [Dec
compareHFDecl]]
      where compareHFClauses :: Type -> [(Name,[Type],Maybe Type)] -> [ClauseQ]
            compareHFClauses :: Type -> [(Name, [Type], Maybe Type)] -> [ClauseQ]
compareHFClauses _ [] = []
            compareHFClauses coArg :: Type
coArg constrs :: [(Name, [Type], Maybe Type)]
constrs =
                let constrs' :: [((Name, [Type], Maybe Type), Integer)]
constrs' = [(Name, [Type], Maybe Type)]
constrs [(Name, [Type], Maybe Type)]
-> [Integer] -> [((Name, [Type], Maybe Type), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [1..]
                    constPairs :: [(((Name, [Type], Maybe Type), Integer),
  ((Name, [Type], Maybe Type), Integer))]
constPairs = [(((Name, [Type], Maybe Type), Integer)
x,((Name, [Type], Maybe Type), Integer)
y)| ((Name, [Type], Maybe Type), Integer)
x<-[((Name, [Type], Maybe Type), Integer)]
constrs', ((Name, [Type], Maybe Type), Integer)
y <- [((Name, [Type], Maybe Type), Integer)]
constrs']
                in ((((Name, [Type], Maybe Type), Integer),
  ((Name, [Type], Maybe Type), Integer))
 -> ClauseQ)
-> [(((Name, [Type], Maybe Type), Integer),
     ((Name, [Type], Maybe Type), Integer))]
-> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (Type
-> (((Name, [Type], Maybe Type), Integer),
    ((Name, [Type], Maybe Type), Integer))
-> ClauseQ
forall a b c.
Ord a =>
Type
-> (((Name, [Type], Maybe Type), a), ((Name, b, c), a)) -> ClauseQ
genClause Type
coArg) [(((Name, [Type], Maybe Type), Integer),
  ((Name, [Type], Maybe Type), Integer))]
constPairs
            genClause :: Type
-> (((Name, [Type], Maybe Type), a), ((Name, b, c), a)) -> ClauseQ
genClause coArg :: Type
coArg ((c :: (Name, [Type], Maybe Type)
c,n :: a
n),(d :: (Name, b, c)
d,m :: a
m))
                | a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
m = Type -> (Name, [Type], Maybe Type) -> ClauseQ
genEqClause Type
coArg (Name, [Type], Maybe Type)
c
                | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
m = (Name, [Type], Maybe Type) -> (Name, b, c) -> ClauseQ
forall b c b c. (Name, b, c) -> (Name, b, c) -> ClauseQ
genLtClause (Name, [Type], Maybe Type)
c (Name, b, c)
d
                | Bool
otherwise = (Name, [Type], Maybe Type) -> (Name, b, c) -> ClauseQ
forall b c b c. (Name, b, c) -> (Name, b, c) -> ClauseQ
genGtClause (Name, [Type], Maybe Type)
c (Name, b, c)
d
            genEqClause :: Type -> (Name,[Type],Maybe Type) -> ClauseQ
            genEqClause :: Type -> (Name, [Type], Maybe Type) -> ClauseQ
genEqClause coArg :: Type
coArg (constr :: Name
constr, args :: [Type]
args,gadtTy :: Maybe Type
gadtTy) = do
              [Name]
varXs <- Int -> String -> Q [Name]
newNames ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args) "x"
              [Name]
varYs <- Int -> String -> Q [Name]
newNames ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args) "y"
              let patX :: Pat
patX = Name -> [Pat] -> Pat
ConP Name
constr ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varXs
              let patY :: Pat
patY = Name -> [Pat] -> Pat
ConP Name
constr ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varYs
              Exp
body <- Type -> [(Name, Name, Type)] -> ExpQ
eqDBody (Type -> Maybe Type -> Type
getBinaryFArg Type
coArg Maybe Type
gadtTy) ([Name] -> [Name] -> [Type] -> [(Name, Name, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
varXs [Name]
varYs [Type]
args)
              Clause -> ClauseQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> ClauseQ) -> Clause -> ClauseQ
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
patX, Pat
patY] (Exp -> Body
NormalB Exp
body) []
            eqDBody :: Type -> [(Name, Name, Type)] -> ExpQ
            eqDBody :: Type -> [(Name, Name, Type)] -> ExpQ
eqDBody coArg :: Type
coArg x :: [(Name, Name, Type)]
x =
                [|compList $(listE $ map (eqDB coArg) x)|]
            eqDB :: Type -> (Name, Name, Type) -> ExpQ
            eqDB :: Type -> (Name, Name, Type) -> ExpQ
eqDB coArg :: Type
coArg (x :: Name
x, y :: Name
y, tp :: Type
tp)
                | Bool -> Bool
not (Type -> Type -> Bool
containsType Type
tp Type
coArg) =
                    [| compare $(varE x) $(varE y) |]
                | Bool
otherwise =
                    [| kcompare $(varE x) $(varE y) |]
            genLtClause :: (Name, b, c) -> (Name, b, c) -> ClauseQ
genLtClause (c :: Name
c, _, _) (d :: Name
d, _, _) =
                [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [FieldPatQ] -> PatQ
recP Name
c [], Name -> [FieldPatQ] -> PatQ
recP Name
d []] (ExpQ -> BodyQ
normalB [| LT |]) []
            genGtClause :: (Name, b, c) -> (Name, b, c) -> ClauseQ
genGtClause (c :: Name
c, _, _) (d :: Name
d, _, _) =
                [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [Name -> [FieldPatQ] -> PatQ
recP Name
c [], Name -> [FieldPatQ] -> PatQ
recP Name
d []] (ExpQ -> BodyQ
normalB [| GT |]) []