From 26b8ddf7c308a8d0e0ff93c64710196f2966bb3a Mon Sep 17 00:00:00 2001
From: ross <unknown>
Date: Fri, 4 Feb 2005 13:36:06 +0000
Subject: [haddock @ 2005-02-04 13:36:05 by ross] sort lists of instances by -
 arity of the type constructors (so higher-kinded instances come first) - name
 of the class - argument types

---
 src/Main.hs | 36 ++++++++++++++++++++++++++++++++++--
 src/Map.hs  |  3 +++
 2 files changed, 37 insertions(+), 2 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index b813c67e..3599d6da 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -28,7 +28,7 @@ import Control.Monad ( when )
 import Control.Monad.Writer ( Writer, runWriter, tell )
 import Data.Char ( isSpace )
 import Data.IORef ( writeIORef )
-import Data.List ( nub, (\\), foldl' )
+import Data.List ( nub, (\\), foldl', sortBy )
 import Data.Maybe ( isJust, isNothing, maybeToList )
 --import Debug.Trace
 import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) )
@@ -1199,7 +1199,7 @@ attachInstances :: [Interface] -> [Interface]
 attachInstances mod_ifaces
   = map attach mod_ifaces
   where
-  inst_map = collectInstances mod_ifaces
+  inst_map = fmap (sortImage instHead) $ collectInstances mod_ifaces
 
   attach iface = iface{ iface_orig_exports = new_exports }
    where
@@ -1230,6 +1230,38 @@ collectInstances ifaces
 		      nm <- nub (concat (map freeTyCons args))
 		    ]
 
+-- simplified type for sorting types, ignoring qualification (not visible
+-- in Haddock output) and unifying special tycons with normal ones.
+data SimpleType = SimpleType HsName [SimpleType] deriving (Eq,Ord)
+
+-- Sort key for instances:
+--	arities of arguments, to place higher-kind instances
+--	name of class
+--	type arguments
+instHead :: (HsContext,(HsQName,[HsType])) -> ([Int],HsName,[SimpleType])
+instHead (ctxt,(cls,args))
+  = (map argCount args, nameOfQName cls, map simplify args)
+  where
+    argCount (HsTyApp t _) = argCount t + 1
+    argCount _ = 0
+
+    simplify (HsForAllType tvs ctxt t) = simplify t
+    simplify (HsTyFun t1 t2) =
+	SimpleType fun_tycon_name [simplify t1, simplify t2]
+    simplify (HsTyTuple b ts) =
+	SimpleType (tuple_tycon_name (length ts - 1)) (map simplify ts)
+    simplify (HsTyApp t1 t2) = SimpleType s (args ++ [simplify t2])
+	where (SimpleType s args) = simplify t1
+    simplify (HsTyVar v) = SimpleType v []
+    simplify (HsTyCon n) = SimpleType (nameOfQName n) []
+    simplify (HsTyDoc t _) = simplify t
+    simplify (HsTyIP n t) = simplify t
+
+-- sortImage f = sortBy (\x y -> compare (f x) (f y))
+sortImage :: Ord b => (a -> b) -> [a] -> [a]
+sortImage f xs = map snd $ sortBy cmp_fst [(f x, x) | x <- xs]
+ where cmp_fst (x,_) (y,_) = compare x y
+
 -- -----------------------------------------------------------------------------
 -- The interface file format.
 -- This has to read interfaces up to Haddock 0.6 (without the short
diff --git a/src/Map.hs b/src/Map.hs
index 8e59f83e..7d4c75df 100644
--- a/src/Map.hs
+++ b/src/Map.hs
@@ -18,6 +18,9 @@ import Data.FiniteMap
 
 type Map k a = FiniteMap k a
 
+instance Functor (FiniteMap k) where
+	fmap f = mapFM (const f)
+
 member :: Ord k => k -> Map k a -> Bool
 member = elemFM
 
-- 
cgit v1.2.3