aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorross <unknown>2005-02-04 13:36:06 +0000
committerross <unknown>2005-02-04 13:36:06 +0000
commit26b8ddf7c308a8d0e0ff93c64710196f2966bb3a (patch)
tree9905d4033d248d52e8b77730ee3346134e53da58 /src
parentfc2cfd2760f995b796936cb23d86fd7dbc6628dd (diff)
[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
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs36
-rw-r--r--src/Map.hs3
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