Commit e1cae123 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Sort modules and packages in debug print (reduce test wobbles)

This affects only the debug print TcRnDriver.pprTcGblEnv, and eliminates
test-suite wobbling (affected me for tc168, tc231) 
parent 1bf423f5
...@@ -19,6 +19,7 @@ module Module ...@@ -19,6 +19,7 @@ module Module
moduleNameSlashes, moduleNameSlashes,
mkModuleName, mkModuleName,
mkModuleNameFS, mkModuleNameFS,
stableModuleNameCmp,
-- * The PackageId type -- * The PackageId type
PackageId, PackageId,
...@@ -26,6 +27,7 @@ module Module ...@@ -26,6 +27,7 @@ module Module
packageIdFS, packageIdFS,
stringToPackageId, stringToPackageId,
packageIdString, packageIdString,
stablePackageIdCmp,
-- * Wired-in PackageIds -- * Wired-in PackageIds
primPackageId, primPackageId,
...@@ -161,6 +163,10 @@ instance Binary ModuleName where ...@@ -161,6 +163,10 @@ instance Binary ModuleName where
put_ bh (ModuleName fs) = put_ bh fs put_ bh (ModuleName fs) = put_ bh fs
get bh = do fs <- get bh; return (ModuleName fs) get bh = do fs <- get bh; return (ModuleName fs)
stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering
-- Compare lexically, not by unique
stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2
pprModuleName :: ModuleName -> SDoc pprModuleName :: ModuleName -> SDoc
pprModuleName (ModuleName nm) = pprModuleName (ModuleName nm) =
getPprStyle $ \ sty -> getPprStyle $ \ sty ->
...@@ -184,7 +190,6 @@ mkModuleNameFS s = ModuleName s ...@@ -184,7 +190,6 @@ mkModuleNameFS s = ModuleName s
moduleNameSlashes :: ModuleName -> String moduleNameSlashes :: ModuleName -> String
moduleNameSlashes = dots_to_slashes . moduleNameString moduleNameSlashes = dots_to_slashes . moduleNameString
where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -213,8 +218,8 @@ instance Binary Module where ...@@ -213,8 +218,8 @@ instance Binary Module where
-- not be stable from run to run of the compiler. -- not be stable from run to run of the compiler.
stableModuleCmp :: Module -> Module -> Ordering stableModuleCmp :: Module -> Module -> Ordering
stableModuleCmp (Module p1 n1) (Module p2 n2) stableModuleCmp (Module p1 n1) (Module p2 n2)
= (packageIdFS p1 `compare` packageIdFS p2) `thenCmp` = (p1 `stablePackageIdCmp` p2) `thenCmp`
(moduleNameFS n1 `compare` moduleNameFS n2) (n1 `stableModuleNameCmp` n2)
mkModule :: PackageId -> ModuleName -> Module mkModule :: PackageId -> ModuleName -> Module
mkModule = Module mkModule = Module
...@@ -254,6 +259,9 @@ instance Uniquable PackageId where ...@@ -254,6 +259,9 @@ instance Uniquable PackageId where
instance Ord PackageId where instance Ord PackageId where
nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
stablePackageIdCmp :: PackageId -> PackageId -> Ordering
stablePackageIdCmp p1 p2 = packageIdFS p1 `compare` packageIdFS p2
instance Outputable PackageId where instance Outputable PackageId where
ppr pid = text (packageIdString pid) ppr pid = text (packageIdString pid)
......
...@@ -82,6 +82,7 @@ import Outputable ...@@ -82,6 +82,7 @@ import Outputable
import DataCon import DataCon
import Type import Type
import Class import Class
import Data.List ( sortBy )
#ifdef GHCI #ifdef GHCI
import Linker import Linker
...@@ -1470,8 +1471,16 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, ...@@ -1470,8 +1471,16 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
, ppr_fam_insts fam_insts , ppr_fam_insts fam_insts
, vcat (map ppr rules) , vcat (map ppr rules)
, ppr_gen_tycons (typeEnvTyCons type_env) , ppr_gen_tycons (typeEnvTyCons type_env)
, ptext (sLit "Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports)) , ptext (sLit "Dependent modules:") <+>
, ptext (sLit "Dependent packages:") <+> ppr (imp_dep_pkgs imports)] ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
, ptext (sLit "Dependent packages:") <+>
ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
where -- The two uses of sortBy are just to reduce unnecessary
-- wobbling in testsuite output
cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
= (mod_name1 `stableModuleNameCmp` mod_name2)
`thenCmp`
(is_boot1 `compare` is_boot2)
pprModGuts :: ModGuts -> SDoc pprModGuts :: ModGuts -> SDoc
pprModGuts (ModGuts { mg_types = type_env, pprModGuts (ModGuts { mg_types = type_env,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment