1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2003
--
module Haddock.Interface.AttachInstances (attachInstances) where
import Haddock.Types
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List
import GHC
import Name
import SrcLoc
import InstEnv
import Class
import TypeRep
import Var hiding (varName)
import TyCon
import PrelNames
import HscTypes
import FastString
#define FSLIT(x) (mkFastString# (x#))
attachInstances :: [Interface] -> [Interface]
attachInstances modules = map attach modules
where
instMap = fmap (map toHsInstHead . sortImage instHead) $ collectInstances modules
attach mod = mod { hmod_export_items = newItems }
where
newItems = map attachExport (hmod_export_items mod)
attachExport (ExportDecl n decl doc _) =
ExportDecl n decl doc (case Map.lookup n instMap of
Nothing -> []
Just instheads -> instheads)
attachExport otherExport = otherExport
-- | Simplified type for sorting types, ignoring qualification (not visible
-- in Haddock output) and unifying special tycons with normal ones.
data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
collectInstances
:: [Interface]
-> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances
collectInstances modules
= Map.fromListWith (flip (++)) tyInstPairs `Map.union`
Map.fromListWith (flip (++)) classInstPairs
where
allInstances = concat (map hmod_instances modules)
classInstPairs = [ (is_cls inst, [instanceHead inst]) |
inst <- allInstances ]
tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances,
Just tycon <- nub (is_tcs inst) ]
instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
instHead (_, _, cls, args)
= (map argCount args, className cls, map simplify args)
where
argCount (AppTy t _) = argCount t + 1
argCount (TyConApp _ ts) = length ts
argCount (FunTy _ _ ) = 2
argCount (ForAllTy _ t) = argCount t
argCount (NoteTy _ t) = argCount t
argCount _ = 0
simplify (ForAllTy _ t) = simplify t
simplify (FunTy t1 t2) =
SimpleType funTyConName [simplify t1, simplify t2]
simplify (AppTy t1 t2) = SimpleType s (args ++ [simplify t2])
where (SimpleType s args) = simplify t1
simplify (TyVarTy v) = SimpleType (tyVarName v) []
simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
simplify (NoteTy _ t) = simplify t
simplify _ = error "simplify"
-- 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
funTyConName = mkWiredInName gHC_PRIM
(mkOccNameFS tcName FSLIT("(->)"))
funTyConKey
(ATyCon funTyCon) -- Relevant TyCon
BuiltInSyntax
toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts)
--------------------------------------------------------------------------------
-- Type -> HsType conversion
--------------------------------------------------------------------------------
toHsPred :: PredType -> HsPred Name
toHsPred (ClassP cls ts) = HsClassP (className cls) (map toLHsType ts)
toHsPred (IParam n t) = HsIParam n (toLHsType t)
toLHsType = noLoc . toHsType
toHsType :: Type -> HsType Name
toHsType t = case t of
TyVarTy v -> HsTyVar (tyVarName v)
AppTy a b -> HsAppTy (toLHsType a) (toLHsType b)
TyConApp tc ts -> case ts of
[] -> HsTyVar (tyConName tc)
_ -> app (tycon tc) ts
FunTy a b -> HsFunTy (toLHsType a) (toLHsType b)
ForAllTy v t -> cvForAll [v] t
PredTy p -> HsPredTy (toHsPred p)
NoteTy _ t -> toHsType t
where
tycon tc = HsTyVar (tyConName tc)
app tc ts = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc (map toHsType ts)
cvForAll vs (ForAllTy v t) = cvForAll (v:vs) t
cvForAll vs t = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t)
tyvarbinders vs = map (noLoc . UserTyVar . tyVarName) vs
|
