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...)
45 RdrNameClassOpPragmas,
49 RdrNameInstancePragmas,
51 extractPatsTyVars, extractRuleBndrsTyVars,
53 mkOpApp, mkClassDecl, mkClassOpSig,
58 cvValSig, cvClassOpSig, cvInstDeclSig
61 #include "HsVersions.h"
64 import Name ( mkClassTyConOcc, mkClassDataConOcc )
65 import OccName ( mkClassTyConOcc, mkClassDataConOcc,
66 mkSuperDictSelOcc, mkDefaultMethodOcc
68 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
69 import Util ( thenCmp )
72 import BasicTypes ( RecFlag(..) )
77 %************************************************************************
79 \subsection{Type synonyms}
81 %************************************************************************
84 type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
85 type RdrNameBangType = BangType RdrName
86 type RdrNameClassOpSig = Sig RdrName
87 type RdrNameConDecl = ConDecl RdrName
88 type RdrNameConDetails = ConDetails RdrName
89 type RdrNameContext = Context RdrName
90 type RdrNameHsDecl = HsDecl RdrName RdrNamePat
91 type RdrNameSpecDataSig = SpecDataSig RdrName
92 type RdrNameDefaultDecl = DefaultDecl RdrName
93 type RdrNameForeignDecl = ForeignDecl RdrName
94 type RdrNameGRHS = GRHS RdrName RdrNamePat
95 type RdrNameGRHSs = GRHSs RdrName RdrNamePat
96 type RdrNameHsBinds = HsBinds RdrName RdrNamePat
97 type RdrNameHsExpr = HsExpr RdrName RdrNamePat
98 type RdrNameHsModule = HsModule RdrName RdrNamePat
99 type RdrNameIE = IE RdrName
100 type RdrNameImportDecl = ImportDecl RdrName
101 type RdrNameInstDecl = InstDecl RdrName RdrNamePat
102 type RdrNameMatch = Match RdrName RdrNamePat
103 type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
104 type RdrNamePat = InPat RdrName
105 type RdrNameHsType = HsType RdrName
106 type RdrNameHsTyVar = HsTyVar RdrName
107 type RdrNameSig = Sig RdrName
108 type RdrNameStmt = Stmt RdrName RdrNamePat
109 type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
110 type RdrNameRuleBndr = RuleBndr RdrName
111 type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
113 type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
115 type RdrNameClassOpPragmas = ClassOpPragmas RdrName
116 type RdrNameClassPragmas = ClassPragmas RdrName
117 type RdrNameDataPragmas = DataPragmas RdrName
118 type RdrNameGenPragmas = GenPragmas RdrName
119 type RdrNameInstancePragmas = InstancePragmas RdrName
123 %************************************************************************
125 \subsection{A few functions over HsSyn at RdrName}
127 %************************************************************************
129 @extractHsTyRdrNames@ finds the free variables of a HsType
130 It's used when making the for-alls explicit.
133 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
134 extractHsTyRdrNames ty = nub (extract_ty ty [])
136 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
137 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
139 go (RuleBndr _) acc = acc
140 go (RuleBndrSig _ ty) acc = extract_ty ty acc
142 extractHsCtxtRdrNames :: Context RdrName -> [RdrName]
143 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
145 extract_ctxt ctxt acc = foldr extract_ass acc ctxt
147 extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
149 extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
150 extract_ty (MonoListTy ty) acc = extract_ty ty acc
151 extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
152 extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
153 extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
154 extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
155 extract_ty (MonoTyVar tv) acc = tv : acc
156 extract_ty (HsForAllTy (Just tvs) ctxt ty)
158 (filter (`notElem` locals) $
159 extract_ctxt ctxt (extract_ty ty []))
161 locals = map getTyVarName tvs
164 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
165 extractPatsTyVars pats = nub (foldr extract_pat [] pats)
167 extract_pat (SigPatIn pat ty) acc = extract_ty ty acc
168 extract_pat WildPatIn acc = acc
169 extract_pat (VarPatIn var) acc = acc
170 extract_pat (LitPatIn _) acc = acc
171 extract_pat (LazyPatIn pat) acc = extract_pat pat acc
172 extract_pat (AsPatIn a pat) acc = extract_pat pat acc
173 extract_pat (NPlusKPatIn n _) acc = acc
174 extract_pat (ConPatIn c pats) acc = foldr extract_pat acc pats
175 extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc)
176 extract_pat (NegPatIn pat) acc = extract_pat pat acc
177 extract_pat (ParPatIn pat) acc = extract_pat pat acc
178 extract_pat (ListPatIn pats) acc = foldr extract_pat acc pats
179 extract_pat (TuplePatIn pats _) acc = foldr extract_pat acc pats
180 extract_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
183 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
184 by deriving them from the name of the class. We fill in the names for the
185 tycon and datacon corresponding to the class, by deriving them from the
186 name of the class itself. This saves recording the names in the interface
187 file (which would be equally good).
189 Similarly for mkClassOpSig and default-method names.
192 mkClassDecl cxt cname tyvars sigs mbinds prags loc
193 = ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_names loc
195 cls_occ = rdrNameOcc cname
196 dname = mkRdrUnqual (mkClassDataConOcc cls_occ)
197 tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
198 sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
199 | n <- [1..length cxt]]
200 -- We number off the superclass selectors, 1, 2, 3 etc so that we
201 -- can construct names for the selectors. Thus
202 -- class (C a, C b) => D a b where ...
203 -- gives superclass selectors
205 -- (We used to call them D_C, but now we can have two different
206 -- superclasses both called C!)
208 mkClassOpSig has_default_method op ty loc
209 | not has_default_method = ClassOpSig op Nothing ty loc
210 | otherwise = ClassOpSig op (Just dm_rn) ty loc
212 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
215 A useful function for building @OpApps@. The operator is always a variable,
216 and we don't know the fixity yet.
219 mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
222 %************************************************************************
224 \subsection[rdrBinding]{Bindings straight out of the parser}
226 %************************************************************************
230 = -- On input we use the Empty/And form rather than a list
232 | RdrAndBindings RdrBinding RdrBinding
234 -- Value bindings havn't been united with their
236 | RdrValBinding RdrNameMonoBinds
238 -- Signatures are mysterious; we can't
239 -- tell if its a Sig or a ClassOpSig,
240 -- so we just save the pieces:
243 -- The remainder all fit into the main HsDecl form
244 | RdrHsDecl RdrNameHsDecl
246 type SigConverter = RdrNameSig -> RdrNameSig
253 (Maybe RdrNameHsType)
257 %************************************************************************
259 \subsection[cvDecls]{Convert various top-level declarations}
261 %************************************************************************
263 We make a point not to throw any user-pragma ``sigs'' at
264 these conversion functions:
267 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
271 cvInstDeclSig sig = sig
273 cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
274 cvClassOpSig sig = sig
278 %************************************************************************
280 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
282 %************************************************************************
284 Function definitions are restructured here. Each is assumed to be recursive
285 initially, and non recursive definitions are discovered by the dependency
289 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
290 -- The mysterious SigConverter converts Sigs to ClassOpSigs
291 -- in class declarations. Mostly it's just an identity function
293 cvBinds sig_cvtr binding
294 = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
295 MonoBind mbs sigs Recursive
300 cvMonoBindsAndSigs :: SigConverter
302 -> (RdrNameMonoBinds, [RdrNameSig])
304 cvMonoBindsAndSigs sig_cvtr fb
305 = mangle_bind (EmptyMonoBinds, []) fb
307 mangle_bind acc RdrNullBind
310 mangle_bind acc (RdrAndBindings fb1 fb2)
311 = mangle_bind (mangle_bind acc fb1) fb2
313 mangle_bind (b_acc, s_acc) (RdrSig sig)
314 = (b_acc, sig_cvtr sig : s_acc)
316 mangle_bind (b_acc, s_acc) (RdrValBinding binding)
317 = (b_acc `AndMonoBinds` binding, s_acc)
321 %************************************************************************
323 \subsection[PrefixToHS-utils]{Utilities for conversion}
325 %************************************************************************
327 Separate declarations into all the various kinds:
330 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
333 (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
335 (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
337 go acc RdrNullBind = acc
338 go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
339 go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
340 go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
341 go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
342 go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)