{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Derive.Ordering
-- Copyright   :  (c) 2010-2011 Patrick Bahr
-- License     :  BSD3
-- Maintainer  :  Patrick Bahr <paba@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Automatically derive instances of @OrdF@.
--
--------------------------------------------------------------------------------
module Data.Comp.Derive.Ordering
    (
     OrdF(..),
     makeOrdF
    ) where

import Data.Comp.Derive.Equality
import Data.Comp.Derive.Utils

import Data.List
import Data.Maybe
import Language.Haskell.TH hiding (Cxt)

{-| Signature ordering. An instance @OrdF f@ gives rise to an instance
  @Ord (Term f)@. -}
class EqF f => OrdF f where
    compareF :: Ord a => f a -> f a -> Ordering


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

{-| Derive an instance of 'OrdF' for a type constructor of any first-order kind
  taking at least one argument. -}
makeOrdF :: Name -> Q [Dec]
makeOrdF :: Name -> Q [Dec]
makeOrdF Name
fname = do
  Just (DataInfo Cxt
_cxt Name
name [TyVarBndr flag]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
  let argNames :: Cxt
argNames = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {flag}. TyVarBndr flag -> Name
tyVarBndrName) (forall a. [a] -> [a]
init [TyVarBndr flag]
args)
      complType :: Type
complType = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
argNames
      preCond :: Cxt
preCond = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Cxt -> Type
mkClassP ''Ord forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])) Cxt
argNames
      classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''OrdF) Type
complType
  Dec
eqAlgDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'compareF  ([Con] -> [Q Clause]
compareFClauses [Con]
constrs)
  forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD Cxt
preCond Type
classType [Dec
eqAlgDecl]]
      where compareFClauses :: [Con] -> [Q Clause]
compareFClauses [] = []
            compareFClauses [Con]
constrs =
                let constrs' :: [((Name, Int), Integer)]
constrs' = forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, Int)
abstractConType [Con]
constrs forall a b. [a] -> [b] -> [(a, b)]
`zip` [Integer
1..]
                    constPairs :: [(((Name, Int), Integer), ((Name, Int), Integer))]
constPairs = [(((Name, Int), Integer)
x,((Name, Int), Integer)
y)| ((Name, Int), Integer)
x<-[((Name, Int), Integer)]
constrs', ((Name, Int), Integer)
y <- [((Name, Int), Integer)]
constrs']
                in forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}.
Ord a =>
(((Name, Int), a), ((Name, b), a)) -> Q Clause
genClause [(((Name, Int), Integer), ((Name, Int), Integer))]
constPairs
            genClause :: (((Name, Int), a), ((Name, b), a)) -> Q Clause
genClause (((Name, Int)
c,a
n),((Name, b)
d,a
m))
                | a
n forall a. Eq a => a -> a -> Bool
== a
m = (Name, Int) -> Q Clause
genEqClause (Name, Int)
c
                | a
n forall a. Ord a => a -> a -> Bool
< a
m = forall {m :: * -> *} {b} {b}.
Quote m =>
(Name, b) -> (Name, b) -> m Clause
genLtClause (Name, Int)
c (Name, b)
d
                | Bool
otherwise = forall {m :: * -> *} {b} {b}.
Quote m =>
(Name, b) -> (Name, b) -> m Clause
genGtClause (Name, Int)
c (Name, b)
d
            genEqClause :: (Name, Int) -> Q Clause
genEqClause (Name
constr, Int
n) = do
              [Name]
varNs <- Int -> String -> Q [Name]
newNames Int
n String
"x"
              [Name]
varNs' <- Int -> String -> Q [Name]
newNames Int
n String
"y"
              let pat :: Pat
pat = Name -> Cxt -> [Pat] -> Pat
ConP Name
constr [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs
                  pat' :: Pat
pat' = Name -> Cxt -> [Pat] -> Pat
ConP Name
constr [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs'
                  vars :: [Exp]
vars = forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
varNs
                  vars' :: [Exp]
vars' = forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
varNs'
                  mkEq :: Exp -> Exp -> m Exp
mkEq Exp
x Exp
y = let (m Exp
x',m Exp
y') = (forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x,forall (m :: * -> *) a. Monad m => a -> m a
return Exp
y)
                             in [| compare $x' $y'|]
                  eqs :: Q Exp
eqs = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {m :: * -> *}. Quote m => Exp -> Exp -> m Exp
mkEq [Exp]
vars [Exp]
vars'
              Exp
body <- [|compList $eqs|]
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat, Pat
pat'] (Exp -> Body
NormalB Exp
body) []
            genLtClause :: (Name, b) -> (Name, b) -> m Clause
genLtClause (Name
c, b
_) (Name
d, b
_) = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
c [], forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
d []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| LT |]) []
            genGtClause :: (Name, b) -> (Name, b) -> m Clause
genGtClause (Name
c, b
_) (Name
d, b
_) = forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
c [], forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
d []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| GT |]) []