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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Haddock.Backends.Xhtml.Specialize
( specialize, specialize'
, specializeTyVarBndrs
, sugar, rename
) where
import Haddock.Syb
import GHC
import Name
import Control.Monad
import Control.Monad.Trans.RWS
import Data.Data
import qualified Data.List as List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
specialize :: (Eq name, Typeable name)
=> Data a
=> name -> HsType name -> a -> a
specialize name details = everywhere (mkT $ specializeStep name details)
specialize' :: (Eq name, Typeable name)
=> Data a
=> [(name, HsType name)] -> a -> a
specialize' = flip $ foldr (uncurry specialize)
specializeStep :: Eq name => name -> HsType name -> HsType name -> HsType name
specializeStep name details (HsTyVar name') | name == name' = details
specializeStep _ _ typ = typ
specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
=> LHsTyVarBndrs name -> [HsType name]
-> HsType name -> HsType name
specializeTyVarBndrs bndrs typs =
specialize' $ zip bndrs' typs
where
bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs
bname (UserTyVar name) = name
bname (KindedTyVar (L _ name) _) = name
sugar :: forall name. (NamedThing name, DataId name)
=> HsType name -> HsType name
sugar =
everywhere $ mkT step
where
step :: HsType name -> HsType name
step = sugarTuples . sugarLists
sugarLists :: NamedThing name => HsType name -> HsType name
sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp)
| isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
where
name' = getName name
strName = occNameString . nameOccName $ name'
sugarLists typ = typ
sugarTuples :: NamedThing name => HsType name -> HsType name
sugarTuples typ =
aux [] typ
where
aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
aux apps (HsParTy (L _ typ')) = aux apps typ'
aux apps (HsTyVar name)
| isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
where
name' = getName name
strName = occNameString . nameOccName $ name'
suitable = case parseTupleArity strName of
Just arity -> arity == length apps
Nothing -> False
aux _ _ = typ
parseTupleArity :: String -> Maybe Int
parseTupleArity ('(':commas) = do
n <- parseCommas commas
guard $ n /= 0
return $ n + 1
where
parseCommas (',':rest) = (+ 1) <$> parseCommas rest
parseCommas ")" = Just 0
parseCommas _ = Nothing
parseTupleArity _ = Nothing
class NamedThing name => SetName name where
setName :: Name -> name -> name
setInternalOccName :: SetName name => OccName -> name -> name
setInternalOccName occ name =
setName nname' name
where
nname = getName name
nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
rename :: SetName name => HsType name -> HsType name
rename = fst . evalRWS undefined Map.empty . renameType -- TODO.
type Rename name a = RWS (Set OccName) () (Map Name name) a
renameType :: SetName name => HsType name -> Rename name (HsType name)
renameType (HsForAllTy ex mspan lbndrs lctx lt) = do
lbndrs' <- renameLTyVarBndrs lbndrs
HsForAllTy
<$> pure ex
<*> pure mspan
<*> pure lbndrs'
<*> located renameContext lctx
<*> renameLType lt
renameType (HsTyVar name) = HsTyVar <$> renameName name
renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
renameType (HsListTy lt) = HsListTy <$> renameLType lt
renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
renameType (HsOpTy la lop lb) =
HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType lb
renameType (HsParTy lt) = HsParTy <$> renameLType lt
renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
renameType t@(HsQuasiQuoteTy _) = pure t
renameType t@(HsSpliceTy _ _) = pure t
renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
renameType t@(HsRecTy _) = pure t
renameType t@(HsCoreTy _) = pure t
renameType (HsExplicitListTy ph ltys) =
HsExplicitListTy ph <$> renameLTypes ltys
renameType (HsExplicitTupleTy phs ltys) =
HsExplicitTupleTy phs <$> renameLTypes ltys
renameType t@(HsTyLit _) = pure t
renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t
renameType HsWildcardTy = pure HsWildcardTy
renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
renameLType = located renameType
renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]
renameLTypes = mapM renameLType
renameContext :: SetName name => HsContext name
-> Rename name (HsContext name)
renameContext = renameLTypes
renameLTyVarBndrs :: SetName name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
renameLTyVarBndrs lbndrs = do
tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs
pure $ lbndrs { hsq_tvs = tys' }
renameTyVarBndr :: SetName name => HsTyVarBndr name
-> Rename name (HsTyVarBndr name)
renameTyVarBndr (UserTyVar name) =
UserTyVar <$> renameNameBndr name
renameTyVarBndr (KindedTyVar name kinds) =
KindedTyVar <$> located renameNameBndr name <*> pure kinds
renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
renameNameBndr :: SetName name => name -> Rename name name
renameNameBndr name = do
fv <- ask
when (getOccName name `Set.member` fv) $
freshName name
renameName name
renameName :: SetName name => name -> Rename name name
renameName name = do
env <- get
pure $ case Map.lookup (getName name) env of
Just name' -> name'
Nothing -> name
freshName :: SetName name => name -> Rename name ()
freshName name = do
fv <- ask
env <- get
let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env)
let name' = setInternalOccName (findFreshName taken occ) name
put $ Map.insert nname name' env
where
nname = getName name
occ = nameOccName nname
findFreshName :: Set OccName -> OccName -> OccName
findFreshName taken =
fromJust . List.find isFresh . alternativeNames
where
isFresh = not . flip Set.member taken
alternativeNames :: OccName -> [OccName]
alternativeNames name =
[ mkVarOcc $ str ++ show i | i :: Int <- [0..] ]
where
str = occNameString name
located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e
|
