From cf7d06b8ac0f47d6ff1c2d3decdb6a50a0fd7502 Mon Sep 17 00:00:00 2001
From: alexbiehl <alexbiehl@gmail.com>
Date: Tue, 9 Feb 2021 12:42:30 +0100
Subject: Stable sort for (data/newtype) instances
---
.../src/Haddock/Interface/AttachInstances.hs | 25 +++++++++++++++-------
1 file changed, 17 insertions(+), 8 deletions(-)
(limited to 'haddock-api/src')
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 6ef0ed19..d5b80888 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -179,19 +179,28 @@ findFixity iface ifaceMap instIfaceMap = \name ->
-- Collecting and sorting instances
--------------------------------------------------------------------------------
+-- | Stable name for stable comparisons. GHC's `Name` uses unstable
+-- ordering based on their `Unique`'s.
+newtype SName = SName Name
+
+instance Eq SName where
+ SName n1 == SName n2 = n1 `stableNameCmp` n2 == EQ
+
+instance Ord SName where
+ SName n1 `compare` SName n2 = n1 `stableNameCmp` n2
-- | Simplified type for sorting types, ignoring qualification (not visible
-- in Haddock output) and unifying special tycons with normal ones.
-- For the benefit of the user (looks nice and predictable) and the
-- tests (which prefer output to be deterministic).
-data SimpleType = SimpleType Name [SimpleType]
+data SimpleType = SimpleType SName [SimpleType]
| SimpleTyLit TyLit
deriving (Eq,Ord)
-instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
+instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], SName, [SimpleType])
instHead (_, _, cls, args)
- = (map argCount args, className cls, map simplify args)
+ = (map argCount args, SName (className cls), map simplify args)
argCount :: Type -> Int
argCount (AppTy t _) = argCount t + 1
@@ -202,12 +211,12 @@ argCount (CastTy t _) = argCount t
argCount _ = 0
simplify :: Type -> SimpleType
-simplify (FunTy _ _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]
+simplify (FunTy _ _ t1 t2) = SimpleType (SName funTyConName) [simplify t1, simplify t2]
simplify (ForAllTy _ t) = simplify t
simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2))
where (SimpleType s ts) = simplify t1
-simplify (TyVarTy v) = SimpleType (tyVarName v) []
-simplify (TyConApp tc ts) = SimpleType (tyConName tc)
+simplify (TyVarTy v) = SimpleType (SName (tyVarName v)) []
+simplify (TyConApp tc ts) = SimpleType (SName (tyConName tc))
(mapMaybe simplify_maybe ts)
simplify (LitTy l) = SimpleTyLit l
simplify (CastTy ty _) = simplify ty
@@ -218,9 +227,9 @@ simplify_maybe (CoercionTy {}) = Nothing
simplify_maybe ty = Just (simplify ty)
-- Used for sorting
-instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)
+instFam :: FamInst -> ([Int], SName, [SimpleType], Int, SimpleType)
instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }
- = (map argCount ts, n, map simplify ts, argCount t, simplify t)
+ = (map argCount ts, SName n, map simplify ts, argCount t, simplify t)
--------------------------------------------------------------------------------
--
cgit v1.2.3
From 7e8c7c3491f3e769368b8e6c767c62a33e996c80 Mon Sep 17 00:00:00 2001
From: alexbiehl <alexbiehl@gmail.com>
Date: Tue, 9 Feb 2021 12:56:15 +0100
Subject: Also make TyLit deterministic
---
haddock-api/src/Haddock/Interface/AttachInstances.hs | 9 +++++++--
1 file changed, 7 insertions(+), 2 deletions(-)
(limited to 'haddock-api/src')
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index d5b80888..530c5690 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -28,6 +28,7 @@ import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )
import qualified Data.Map as Map
import qualified Data.Set as Set
+import GHC.Data.FastString (unpackFS)
import GHC.Core.Class
import GHC.Driver.Session
import GHC.Core (isOrphan)
@@ -194,7 +195,9 @@ instance Ord SName where
-- For the benefit of the user (looks nice and predictable) and the
-- tests (which prefer output to be deterministic).
data SimpleType = SimpleType SName [SimpleType]
- | SimpleTyLit TyLit
+ | SimpleIntTyLit Integer
+ | SimpleStringTyLit String
+ | SimpleCharTyLit Char
deriving (Eq,Ord)
@@ -218,7 +221,9 @@ simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2))
simplify (TyVarTy v) = SimpleType (SName (tyVarName v)) []
simplify (TyConApp tc ts) = SimpleType (SName (tyConName tc))
(mapMaybe simplify_maybe ts)
-simplify (LitTy l) = SimpleTyLit l
+simplify (LitTy (NumTyLit n)) = SimpleIntTyLit n
+simplify (LitTy (StrTyLit s)) = SimpleStringTyLit (unpackFS s)
+simplify (LitTy (CharTyLit c)) = SimpleCharTyLit c
simplify (CastTy ty _) = simplify ty
simplify (CoercionTy _) = error "simplify:Coercion"
--
cgit v1.2.3