2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
6 (Well, really, for specialisations involving @RdrName@s, even if
7 they are used somewhat later on in the compiler...)
47 RdrNameClassOpPragmas,
51 RdrNameInstancePragmas,
53 extractHsTyRdrTyVars, extractHsTysRdrTyVars,
55 extractRuleBndrsTyVars,
56 extractHsCtxtRdrTyVars,
58 mkOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
63 cvValSig, cvClassOpSig, cvInstDeclSig
66 #include "HsVersions.h"
69 import HsPat ( collectSigTysFromPats )
70 import Name ( mkClassTyConOcc, mkClassDataConOcc )
71 import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
72 mkSuperDictSelOcc, mkDefaultMethodOcc
74 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
75 import Util ( thenCmp )
78 import BasicTypes ( RecFlag(..) )
83 %************************************************************************
85 \subsection{Type synonyms}
87 %************************************************************************
90 type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
91 type RdrNameBangType = BangType RdrName
92 type RdrNameClassOpSig = Sig RdrName
93 type RdrNameConDecl = ConDecl RdrName
94 type RdrNameConDetails = ConDetails RdrName
95 type RdrNameContext = HsContext RdrName
96 type RdrNameHsDecl = HsDecl RdrName RdrNamePat
97 type RdrNameSpecDataSig = SpecDataSig RdrName
98 type RdrNameDefaultDecl = DefaultDecl RdrName
99 type RdrNameForeignDecl = ForeignDecl RdrName
100 type RdrNameGRHS = GRHS RdrName RdrNamePat
101 type RdrNameGRHSs = GRHSs RdrName RdrNamePat
102 type RdrNameHsBinds = HsBinds RdrName RdrNamePat
103 type RdrNameHsExpr = HsExpr RdrName RdrNamePat
104 type RdrNameHsModule = HsModule RdrName RdrNamePat
105 type RdrNameIE = IE RdrName
106 type RdrNameImportDecl = ImportDecl RdrName
107 type RdrNameInstDecl = InstDecl RdrName RdrNamePat
108 type RdrNameMatch = Match RdrName RdrNamePat
109 type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
110 type RdrNamePat = InPat RdrName
111 type RdrNameHsType = HsType RdrName
112 type RdrNameHsTyVar = HsTyVarBndr RdrName
113 type RdrNameSig = Sig RdrName
114 type RdrNameStmt = Stmt RdrName RdrNamePat
115 type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
116 type RdrNameRuleBndr = RuleBndr RdrName
117 type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
118 type RdrNameDeprecation = DeprecDecl RdrName
119 type RdrNameFixitySig = FixitySig RdrName
121 type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
123 type RdrNameClassOpPragmas = ClassOpPragmas RdrName
124 type RdrNameClassPragmas = ClassPragmas RdrName
125 type RdrNameDataPragmas = DataPragmas RdrName
126 type RdrNameGenPragmas = GenPragmas RdrName
127 type RdrNameInstancePragmas = InstancePragmas RdrName
131 %************************************************************************
133 \subsection{A few functions over HsSyn at RdrName}
135 %************************************************************************
137 @extractHsTyRdrNames@ finds the free variables of a HsType
138 It's used when making the for-alls explicit.
141 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
142 extractHsTyRdrNames ty = nub (extract_ty ty [])
144 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
145 extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
147 extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName]
148 extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys))
150 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
151 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
153 go (RuleBndr _) acc = acc
154 go (RuleBndrSig _ ty) acc = extract_ty ty acc
156 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
157 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
158 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
159 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
161 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
163 extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys
164 extract_pred (HsPIParam n ty) acc = extract_ty ty acc
166 extract_tys tys = foldr extract_ty [] tys
168 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
169 extract_ty (HsListTy ty) acc = extract_ty ty acc
170 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
171 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
172 extract_ty (HsPredTy p) acc = extract_pred p acc
173 extract_ty (HsUsgTy usg ty) acc = extract_ty ty acc
174 extract_ty (HsUsgForAllTy uv ty) acc = extract_ty ty acc
175 extract_ty (HsTyVar tv) acc = tv : acc
176 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
177 extract_ty (HsForAllTy (Just tvs) ctxt ty)
179 (filter (`notElem` locals) $
180 extract_ctxt ctxt (extract_ty ty []))
182 locals = hsTyVarNames tvs
185 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
186 extractPatsTyVars = filter isRdrTyVar .
189 collectSigTysFromPats
192 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
193 by deriving them from the name of the class. We fill in the names for the
194 tycon and datacon corresponding to the class, by deriving them from the
195 name of the class itself. This saves recording the names in the interface
196 file (which would be equally good).
198 Similarly for mkConDecl, mkClassOpSig and default-method names.
201 mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
202 = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname dwname sc_sel_names loc
204 cls_occ = rdrNameOcc cname
205 data_occ = mkClassDataConOcc cls_occ
206 dname = mkRdrUnqual data_occ
207 dwname = mkRdrUnqual (mkWorkerOcc data_occ)
208 tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
209 sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
210 | n <- [1..length cxt]]
211 -- We number off the superclass selectors, 1, 2, 3 etc so that we
212 -- can construct names for the selectors. Thus
213 -- class (C a, C b) => D a b where ...
214 -- gives superclass selectors
216 -- (We used to call them D_C, but now we can have two different
217 -- superclasses both called C!)
219 mkClassOpSig has_default_method op ty loc
220 = ClassOpSig op dm_rn has_default_method ty loc
222 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
224 mkConDecl cname ex_vars cxt details loc
225 = ConDecl cname wkr_name ex_vars cxt details loc
227 wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
230 A useful function for building @OpApps@. The operator is always a variable,
231 and we don't know the fixity yet.
234 mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
237 %************************************************************************
239 \subsection[rdrBinding]{Bindings straight out of the parser}
241 %************************************************************************
245 = -- On input we use the Empty/And form rather than a list
247 | RdrAndBindings RdrBinding RdrBinding
249 -- Value bindings havn't been united with their
251 | RdrValBinding RdrNameMonoBinds
253 -- Signatures are mysterious; we can't
254 -- tell if its a Sig or a ClassOpSig,
255 -- so we just save the pieces:
258 -- The remainder all fit into the main HsDecl form
259 | RdrHsDecl RdrNameHsDecl
261 type SigConverter = RdrNameSig -> RdrNameSig
268 (Maybe RdrNameHsType)
272 %************************************************************************
274 \subsection[cvDecls]{Convert various top-level declarations}
276 %************************************************************************
278 We make a point not to throw any user-pragma ``sigs'' at
279 these conversion functions:
282 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
286 cvInstDeclSig sig = sig
288 cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var (panic "cvClassOpSig:dm_name")
291 cvClassOpSig sig = sig
295 %************************************************************************
297 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
299 %************************************************************************
301 Function definitions are restructured here. Each is assumed to be recursive
302 initially, and non recursive definitions are discovered by the dependency
306 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
307 -- The mysterious SigConverter converts Sigs to ClassOpSigs
308 -- in class declarations. Mostly it's just an identity function
310 cvBinds sig_cvtr binding
311 = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
312 MonoBind mbs sigs Recursive
317 cvMonoBindsAndSigs :: SigConverter
319 -> (RdrNameMonoBinds, [RdrNameSig])
321 cvMonoBindsAndSigs sig_cvtr fb
322 = mangle_bind (EmptyMonoBinds, []) fb
324 mangle_bind acc RdrNullBind
327 mangle_bind acc (RdrAndBindings fb1 fb2)
328 = mangle_bind (mangle_bind acc fb1) fb2
330 mangle_bind (b_acc, s_acc) (RdrSig sig)
331 = (b_acc, sig_cvtr sig : s_acc)
333 mangle_bind (b_acc, s_acc) (RdrValBinding binding)
334 = (b_acc `AndMonoBinds` binding, s_acc)
338 %************************************************************************
340 \subsection[PrefixToHS-utils]{Utilities for conversion}
342 %************************************************************************
344 Separate declarations into all the various kinds:
347 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
350 (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
352 (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
354 go acc RdrNullBind = acc
355 go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
356 go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
357 go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
358 go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
359 go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)