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...)
46 extractHsTyRdrNames, extractHsTyRdrTyVars,
47 extractHsCtxtRdrTyVars, extractGenericPatTyVars,
49 mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
50 mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
55 cvValSig, cvClassOpSig, cvInstDeclSig,
59 #include "HsVersions.h"
61 import HsSyn -- Lots of it
62 import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
63 mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
66 import PrelNames ( minusName, negateName, fromIntegerName, fromRationalName )
67 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
69 import BasicTypes ( RecFlag(..) )
70 import Class ( DefMeth (..) )
74 %************************************************************************
76 \subsection{Type synonyms}
78 %************************************************************************
81 type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
82 type RdrNameBangType = BangType RdrName
83 type RdrNameClassOpSig = Sig RdrName
84 type RdrNameConDecl = ConDecl RdrName
85 type RdrNameConDetails = ConDetails RdrName
86 type RdrNameContext = HsContext RdrName
87 type RdrNameHsDecl = HsDecl RdrName RdrNamePat
88 type RdrNameDefaultDecl = DefaultDecl RdrName
89 type RdrNameForeignDecl = ForeignDecl RdrName
90 type RdrNameGRHS = GRHS RdrName RdrNamePat
91 type RdrNameGRHSs = GRHSs RdrName RdrNamePat
92 type RdrNameHsBinds = HsBinds RdrName RdrNamePat
93 type RdrNameHsExpr = HsExpr RdrName RdrNamePat
94 type RdrNameHsModule = HsModule RdrName RdrNamePat
95 type RdrNameIE = IE RdrName
96 type RdrNameImportDecl = ImportDecl RdrName
97 type RdrNameInstDecl = InstDecl RdrName RdrNamePat
98 type RdrNameMatch = Match RdrName RdrNamePat
99 type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
100 type RdrNamePat = InPat RdrName
101 type RdrNameHsType = HsType RdrName
102 type RdrNameHsTyVar = HsTyVarBndr RdrName
103 type RdrNameSig = Sig RdrName
104 type RdrNameStmt = Stmt RdrName RdrNamePat
105 type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
107 type RdrNameRuleBndr = RuleBndr RdrName
108 type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
109 type RdrNameDeprecation = DeprecDecl RdrName
110 type RdrNameFixitySig = FixitySig RdrName
112 type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
116 %************************************************************************
118 \subsection{A few functions over HsSyn at RdrName}
120 %************************************************************************
122 @extractHsTyRdrNames@ finds the free variables of a HsType
123 It's used when making the for-alls explicit.
126 extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
127 extractHsTyRdrNames ty = nub (extract_ty ty [])
129 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
130 extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
132 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
133 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
134 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
135 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
137 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
139 extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
140 extract_pred (HsIParam n ty) acc = extract_ty ty acc
142 extract_tys tys = foldr extract_ty [] tys
144 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
145 extract_ty (HsListTy ty) acc = extract_ty ty acc
146 extract_ty (HsPArrTy ty) acc = extract_ty ty acc
147 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
148 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
149 extract_ty (HsPredTy p) acc = extract_pred p acc
150 extract_ty (HsTyVar tv) acc = tv : acc
151 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
153 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
154 extract_ty (HsNumTy num) acc = acc
156 extract_ty (HsForAllTy (Just tvs) ctxt ty)
158 (filter (`notElem` locals) $
159 extract_ctxt ctxt (extract_ty ty []))
161 locals = hsTyVarNames tvs
163 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
164 -- Get the type variables out of the type patterns in a bunch of
165 -- possibly-generic bindings in a class declaration
166 extractGenericPatTyVars binds
167 = filter isRdrTyVar (nub (get binds []))
169 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
170 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
173 get_m (Match (TypePatIn ty : _) _ _) acc = extract_ty ty acc
174 get_m other acc = acc
178 %************************************************************************
180 \subsection{Construction functions for Rdr stuff}
182 %************************************************************************
184 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
185 by deriving them from the name of the class. We fill in the names for the
186 tycon and datacon corresponding to the class, by deriving them from the
187 name of the class itself. This saves recording the names in the interface
188 file (which would be equally good).
190 Similarly for mkConDecl, mkClassOpSig and default-method names.
192 *** See "THE NAMING STORY" in HsDecls ****
195 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
196 = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
197 tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
198 tcdSysNames = new_names, tcdLoc = loc }
200 cls_occ = rdrNameOcc cname
201 data_occ = mkClassDataConOcc cls_occ
202 dname = mkRdrUnqual data_occ
203 dwname = mkRdrUnqual (mkWorkerOcc data_occ)
204 tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
205 sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
206 | n <- [1..length cxt]]
207 -- We number off the superclass selectors, 1, 2, 3 etc so that we
208 -- can construct names for the selectors. Thus
209 -- class (C a, C b) => D a b where ...
210 -- gives superclass selectors
212 -- (We used to call them D_C, but now we can have two different
213 -- superclasses both called C!)
214 new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
216 mkTyData new_or_data (context, tname, tyvars) list_con i maybe src
217 = let t_occ = rdrNameOcc tname
218 name1 = mkRdrUnqual (mkGenOcc1 t_occ)
219 name2 = mkRdrUnqual (mkGenOcc2 t_occ)
220 in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
221 tcdTyVars = tyvars, tcdCons = list_con, tcdNCons = i,
222 tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
224 mkClassOpSigDM op ty loc
225 = ClassOpSig op (DefMeth dm_rn) ty loc
227 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
229 mkConDecl cname ex_vars cxt details loc
230 = ConDecl cname wkr_name ex_vars cxt details loc
232 wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
236 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
237 -- If the type checker sees (negate 3#) it will barf, because negate
238 -- can't take an unboxed arg. But that is exactly what it will see when
239 -- we write "-3#". So we have to do the negation right now!
241 -- We also do the same service for boxed literals, because this function
242 -- is also used for patterns (which, remember, are parsed as expressions)
243 -- and pattern don't have negation in them.
245 -- Finally, it's important to represent minBound as minBound, and not
246 -- as (negate (-minBound)), becuase the latter is out of range.
248 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
249 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
250 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
252 mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n)
253 mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
254 mkHsNegApp expr = NegApp expr negateName
257 A useful function for building @OpApps@. The operator is always a
258 variable, and we don't know the fixity yet.
261 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
264 These are the bits of syntax that contain rebindable names
265 See RnEnv.lookupSyntaxName
268 mkHsIntegral i = HsIntegral i fromIntegerName
269 mkHsFractional f = HsFractional f fromRationalName
270 mkNPlusKPat n k = NPlusKPatIn n k minusName
274 %************************************************************************
276 \subsection[rdrBinding]{Bindings straight out of the parser}
278 %************************************************************************
282 = -- On input we use the Empty/And form rather than a list
284 | RdrAndBindings RdrBinding RdrBinding
286 -- Value bindings havn't been united with their
288 | RdrValBinding RdrNameMonoBinds
290 -- Signatures are mysterious; we can't
291 -- tell if its a Sig or a ClassOpSig,
292 -- so we just save the pieces:
295 -- The remainder all fit into the main HsDecl form
296 | RdrHsDecl RdrNameHsDecl
298 type SigConverter = RdrNameSig -> RdrNameSig
305 (Maybe RdrNameHsType)
309 %************************************************************************
311 \subsection[cvDecls]{Convert various top-level declarations}
313 %************************************************************************
315 We make a point not to throw any user-pragma ``sigs'' at
316 these conversion functions:
319 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
323 cvInstDeclSig sig = sig
325 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
326 cvClassOpSig sig = sig
330 %************************************************************************
332 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
334 %************************************************************************
336 Function definitions are restructured here. Each is assumed to be recursive
337 initially, and non recursive definitions are discovered by the dependency
341 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
342 -- The mysterious SigConverter converts Sigs to ClassOpSigs
343 -- in class declarations. Mostly it's just an identity function
345 cvBinds sig_cvtr binding
346 = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
347 MonoBind mbs sigs Recursive
352 cvMonoBindsAndSigs :: SigConverter
354 -> (RdrNameMonoBinds, [RdrNameSig])
356 cvMonoBindsAndSigs sig_cvtr fb
357 = mangle_bind (EmptyMonoBinds, []) fb
359 mangle_bind acc RdrNullBind
362 mangle_bind acc (RdrAndBindings fb1 fb2)
363 = mangle_bind (mangle_bind acc fb1) fb2
365 mangle_bind (b_acc, s_acc) (RdrSig sig)
366 = (b_acc, sig_cvtr sig : s_acc)
368 mangle_bind (b_acc, s_acc) (RdrValBinding binding)
369 = (b_acc `AndMonoBinds` binding, s_acc)
373 %************************************************************************
375 \subsection[PrefixToHS-utils]{Utilities for conversion}
377 %************************************************************************
379 Separate declarations into all the various kinds:
382 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
385 (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
387 (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
389 go acc RdrNullBind = acc
390 go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
391 go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
392 go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
393 go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
394 go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)