module Data.Derive.Ord(makeOrd) where
import Control.Monad(guard)
import Language.Haskell.TH.All
#ifdef GUESS
import Data.DeriveGuess
instance Eq (DataName a) where
example = (,) "Ord" [d|
instance Ord a => Ord (DataName a) where
compare a b = check a b
where
check CtorZero CtorZero = compare () ()
check (CtorOne x1) (CtorOne y1) = compare (tup1 x1) (tup1 y1)
check (CtorTwo x1 x2) (CtorTwo y1 y2) = compare (x1,x2) (y1,y2)
check (CtorTwo' x1 x2) (CtorTwo' y1 y2) = compare (x1,x2) (y1,y2)
check x y = compare (tag x) (tag y)
tag (CtorZero{}) = 0
tag (CtorOne{}) = 1
tag (CtorTwo{}) = 2
tag (CtorTwo'{}) = 3
|]
#endif
makeOrd :: Derivation
makeOrd = derivation ord' "Ord"
ord' dat = [instance_context ["Ord"] "Ord" dat [FunD (mkName "compare") [(Clause
[(VarP (lName "a")),(VarP (lName "b"))] (NormalB (applyWith (VarE (lName
"check")) [(VarE (lName "a")),(VarE (lName "b"))])) (FunD (lName "check"
) ((map (\ (_,ctor) -> (Clause [(ConP (mkName (ctorName ctor)) ((map (
\field -> (VarP (lName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[
])),(ConP (mkName (ctorName ctor)) ((map (\field -> (VarP (lName ("y" ++
show field)))) (id [1..ctorArity ctor]))++[]))] (NormalB (applyWith (VarE (
mkName "compare")) [(TupE ((map (\field -> (VarE (lName ("x" ++ show field
)))) (id [1..ctorArity ctor]))++[])),(TupE ((map (\field -> (VarE (lName (
"y" ++ show field)))) (id [1..ctorArity ctor]))++[]))])) [])) (id (zip [0..
] (dataCtors dat))))
++ emptyIfOneCtor
[(Clause [(VarP (lName "x")),(VarP (lName "y"))] (
NormalB (applyWith (VarE (mkName "compare")) [(AppE (VarE (lName "tag")) (
VarE (lName "x"))),(AppE (VarE (lName "tag")) (VarE (lName "y")))])) [])
])
: emptyIfOneCtor
[FunD (lName "tag") ((map (\ (ctorInd,ctor) -> (Clause [((flip RecP [
]) (mkName (ctorName ctor)))] (NormalB (LitE (IntegerL ctorInd))) [])) (id
(zip [0..] (dataCtors dat)))))] ))]]]
where lName = mkName . (++ "_Data_Derive_Ord__")
emptyIfOneCtor = (guard (length (dataCtors dat) > 1) >>)