@@ -50,10 +50,14 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
5050 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
5151 , mn == fromMaybe mn mn'
5252 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
53− | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) eq
53+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Eq")
5454 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
5555 , mn == fromMaybe mn mn'
5656 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
57+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Ord")
58+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
59+ , mn == fromMaybe mn mn'
60+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
5761deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
5862 = throwError . errorMessage $ CannotDerive className tys
5963deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
@@ -77,9 +81,6 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
7781typesProxy :: ModuleName
7882typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
7983
80−eq :: ProperName 'ClassName
81−eq = ProperName "Eq"
82−
8384deriveGeneric
8485 :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
8586 => ModuleName
@@ -265,6 +266,62 @@ deriveEq mn ds tyConNm = do
265266 $ decomposeRec rec
266267 toEqTest l r _ = preludeEq l r
267268
269+deriveOrd ::
270+ forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
271+ => ModuleName
272+ -> [Declaration]
273+ -> ProperName 'TypeName
274+ -> m [Declaration]
275+deriveOrd mn ds tyConNm = do
276+ tyCon <- findTypeDecl tyConNm ds
277+ compareFun <- mkCompareFunction tyCon
278+ return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]
279+ where
280+ mkCompareFunction :: Declaration -> m Expr
281+ mkCompareFunction (DataDeclaration _ _ _ args) = lamCase2 "$x" "$y" <$> (concat <$> mapM mkCtorClauses args)
282+ mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d
283+ mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration"
284+
285+ preludeCtor :: String -> Expr
286+ preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName
287+
288+ preludeAppend :: Expr -> Expr -> Expr
289+ preludeAppend = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.append)))
290+
291+ preludeCompare :: Expr -> Expr -> Expr
292+ preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare)))
293+
294+ mkCtorClauses :: (ProperName 'ConstructorName, [Type]) -> m [CaseAlternative]
295+ mkCtorClauses (ctorName, tys) = do
296+ [identsL, identsR] <- replicateM 2 (replicateM (length tys) freshIdent')
297+ let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
298+ return [ CaseAlternative [ caseBinder identsL
299+ , caseBinder identsR
300+ ]
301+ (Right (appendAll tests))
302+ , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
303+ , NullBinder
304+ ]
305+ (Right (preludeCtor "LT"))
306+ , CaseAlternative [ NullBinder
307+ , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
308+ ]
309+ (Right (preludeCtor "GT"))
310+ ]
311+ where
312+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
313+
314+ appendAll :: [Expr] -> Expr
315+ appendAll [] = preludeCtor "EQ"
316+ appendAll xs = foldl1 preludeAppend xs
317+
318+ toOrdering :: Expr -> Expr -> Type -> Expr
319+ toOrdering l r ty | Just rec <- objectType ty =
320+ appendAll
321+ . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
322+ $ decomposeRec rec
323+ toOrdering l r _ = preludeCompare l r
324+
268325findTypeDecl
269326 :: (Functor m, MonadError MultipleErrors m)
270327 => ProperName 'TypeName