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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
{-# LANGUAGE MagicHash #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
-- Copyright : (c) David Waern 2006-2009
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
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
#if __GLASGOW_HASKELL__ >= 610 && __GHC_PATCHLEVEL__ >= 2
import TypeRep hiding (funTyConName)
#else
import TypeRep
#endif
import Var hiding (varName)
import TyCon
import PrelNames
import HscTypes
import FastString
#define FSLIT(x) (mkFastString# (x#))
attachInstances :: [Interface] -> [Name] -> [Interface]
attachInstances ifaces filterNames = map attach ifaces
where
instMap =
fmap (map toHsInstHead . sortImage instHead) $
collectInstances ifaces filterNames
attach iface = iface { ifaceExportItems = newItems }
where
newItems = map attachExport (ifaceExportItems iface)
attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _)
| isClassDecl d || isDataDecl d || isFamilyDecl d =
ExportDecl decl doc subs (case Map.lookup (tcdName d) instMap of
Nothing -> []
Just instheads -> instheads)
attachExport export = export
--------------------------------------------------------------------------------
-- Collecting and sorting instances
--------------------------------------------------------------------------------
-- | 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]
-> [Name]
-> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances
collectInstances ifaces _ -- filterNames
= Map.fromListWith (flip (++)) tyInstPairs `Map.union`
Map.fromListWith (flip (++)) classInstPairs
where
allInstances = concatMap ifaceInstances ifaces
classInstPairs = [ (is_cls inst, [instanceHead inst]) |
inst <- allInstances ]
-- unfinished filtering of internal instances
-- Just n <- nub (is_tcs inst) ]
-- n `elem` filterNames ]
tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances,
Just tycon <- nub (is_tcs inst) ]
-- TODO: should we support PredTy here?
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 _ = 0
simplify (ForAllTy _ t) = simplify t
simplify (FunTy t1 t2) =
SimpleType funTyConName [simplify t1, simplify t2]
simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
where (SimpleType s ts) = simplify t1
simplify (TyVarTy v) = SimpleType (tyVarName v) []
simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
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 :: Name
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)
toHsPred (EqPred t1 t2) = HsEqualP (toLHsType t1) (toLHsType t2)
toLHsType :: Type -> Located (HsType Name)
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
t1:t2:rest
| isSymOcc . nameOccName . tyConName $ tc ->
app (HsOpTy (toLHsType t1) (noLoc . tyConName $ tc) (toLHsType t2)) rest
_ -> app (tycon tc) ts
FunTy a b -> HsFunTy (toLHsType a) (toLHsType b)
ForAllTy v ty -> cvForAll [v] ty
PredTy p -> HsPredTy (toHsPred p)
where
tycon = HsTyVar . tyConName
app tc = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc . map toHsType
cvForAll vs (ForAllTy v ty) = cvForAll (v:vs) ty
cvForAll vs ty = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType ty)
tyvarbinders = map (noLoc . UserTyVar . tyVarName)
|
