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,
56 cvValSig, cvClassOpSig, cvInstDeclSig,
60 #include "HsVersions.h"
62 import HsSyn -- Lots of it
63 import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
64 mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
67 import PrelNames ( unboundKey )
68 import Name ( mkInternalName )
69 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
71 import BasicTypes ( RecFlag(..) )
72 import SrcLoc ( builtinSrcLoc )
73 import Class ( DefMeth (..) )
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 = HsContext RdrName
90 type RdrNameHsDecl = HsDecl RdrName RdrNamePat
91 type RdrNameDefaultDecl = DefaultDecl RdrName
92 type RdrNameForeignDecl = ForeignDecl RdrName
93 type RdrNameGRHS = GRHS RdrName RdrNamePat
94 type RdrNameGRHSs = GRHSs RdrName RdrNamePat
95 type RdrNameHsBinds = HsBinds RdrName RdrNamePat
96 type RdrNameHsExpr = HsExpr RdrName RdrNamePat
97 type RdrNameHsModule = HsModule RdrName RdrNamePat
98 type RdrNameIE = IE RdrName
99 type RdrNameImportDecl = ImportDecl RdrName
100 type RdrNameInstDecl = InstDecl RdrName RdrNamePat
101 type RdrNameMatch = Match RdrName RdrNamePat
102 type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
103 type RdrNamePat = InPat RdrName
104 type RdrNameHsType = HsType RdrName
105 type RdrNameHsTyVar = HsTyVarBndr RdrName
106 type RdrNameSig = Sig RdrName
107 type RdrNameStmt = Stmt RdrName RdrNamePat
108 type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
110 type RdrNameRuleBndr = RuleBndr RdrName
111 type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
112 type RdrNameDeprecation = DeprecDecl RdrName
113 type RdrNameFixitySig = FixitySig RdrName
115 type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
119 %************************************************************************
121 \subsection{A few functions over HsSyn at RdrName}
123 %************************************************************************
125 @extractHsTyRdrNames@ finds the free variables of a HsType
126 It's used when making the for-alls explicit.
129 extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
130 extractHsTyRdrNames ty = nub (extract_ty ty [])
132 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
133 extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
135 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
136 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
137 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
138 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
140 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
142 extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
143 extract_pred (HsIParam n ty) acc = extract_ty ty acc
145 extract_tys tys = foldr extract_ty [] tys
147 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
148 extract_ty (HsListTy ty) acc = extract_ty ty acc
149 extract_ty (HsPArrTy ty) acc = extract_ty ty acc
150 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
151 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
152 extract_ty (HsPredTy p) acc = extract_pred p acc
153 extract_ty (HsTyVar tv) acc = tv : acc
154 extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
156 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
157 extract_ty (HsNumTy num) acc = acc
158 extract_ty (HsKindSig ty k) acc = extract_ty ty acc
159 extract_ty (HsForAllTy (Just tvs) ctxt ty)
161 (filter (`notElem` locals) $
162 extract_ctxt ctxt (extract_ty ty []))
164 locals = hsTyVarNames tvs
166 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
167 -- Get the type variables out of the type patterns in a bunch of
168 -- possibly-generic bindings in a class declaration
169 extractGenericPatTyVars binds
170 = filter isRdrTyVar (nub (get binds []))
172 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
173 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
176 get_m (Match (TypePatIn ty : _) _ _) acc = extract_ty ty acc
177 get_m other acc = acc
181 %************************************************************************
183 \subsection{Construction functions for Rdr stuff}
185 %************************************************************************
187 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
188 by deriving them from the name of the class. We fill in the names for the
189 tycon and datacon corresponding to the class, by deriving them from the
190 name of the class itself. This saves recording the names in the interface
191 file (which would be equally good).
193 Similarly for mkConDecl, mkClassOpSig and default-method names.
195 *** See "THE NAMING STORY" in HsDecls ****
198 mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
199 = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
200 tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
201 tcdSysNames = new_names, tcdLoc = loc }
203 cls_occ = rdrNameOcc cname
204 data_occ = mkClassDataConOcc cls_occ
205 dname = mkRdrUnqual data_occ
206 dwname = mkRdrUnqual (mkWorkerOcc data_occ)
207 tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
208 sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
209 | n <- [1..length cxt]]
210 -- We number off the superclass selectors, 1, 2, 3 etc so that we
211 -- can construct names for the selectors. Thus
212 -- class (C a, C b) => D a b where ...
213 -- gives superclass selectors
215 -- (We used to call them D_C, but now we can have two different
216 -- superclasses both called C!)
217 new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
219 mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
220 = let t_occ = rdrNameOcc tname
221 name1 = mkRdrUnqual (mkGenOcc1 t_occ)
222 name2 = mkRdrUnqual (mkGenOcc2 t_occ)
223 in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
224 tcdTyVars = tyvars, tcdCons = data_cons,
225 tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
227 mkClassOpSigDM op ty loc
228 = ClassOpSig op (DefMeth dm_rn) ty loc
230 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
232 mkConDecl cname ex_vars cxt details loc
233 = ConDecl cname wkr_name ex_vars cxt details loc
235 wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
239 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
240 -- If the type checker sees (negate 3#) it will barf, because negate
241 -- can't take an unboxed arg. But that is exactly what it will see when
242 -- we write "-3#". So we have to do the negation right now!
244 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
245 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
246 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
247 mkHsNegApp expr = NegApp expr placeHolderName
250 A useful function for building @OpApps@. The operator is always a
251 variable, and we don't know the fixity yet.
254 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
257 These are the bits of syntax that contain rebindable names
258 See RnEnv.lookupSyntaxName
261 mkHsIntegral i = HsIntegral i placeHolderName
262 mkHsFractional f = HsFractional f placeHolderName
263 mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
264 mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
266 placeHolderName = mkInternalName unboundKey
267 (mkVarOcc FSLIT("syntaxPlaceHolder"))
272 %************************************************************************
274 \subsection[rdrBinding]{Bindings straight out of the parser}
276 %************************************************************************
280 = -- On input we use the Empty/And form rather than a list
282 | RdrAndBindings RdrBinding RdrBinding
284 -- Value bindings havn't been united with their
286 | RdrValBinding RdrNameMonoBinds
288 -- Signatures are mysterious; we can't
289 -- tell if its a Sig or a ClassOpSig,
290 -- so we just save the pieces:
293 -- The remainder all fit into the main HsDecl form
294 | RdrHsDecl RdrNameHsDecl
296 type SigConverter = RdrNameSig -> RdrNameSig
303 (Maybe RdrNameHsType)
307 %************************************************************************
309 \subsection[cvDecls]{Convert various top-level declarations}
311 %************************************************************************
313 We make a point not to throw any user-pragma ``sigs'' at
314 these conversion functions:
317 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
321 cvInstDeclSig sig = sig
323 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
324 cvClassOpSig sig = sig
328 %************************************************************************
330 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
332 %************************************************************************
334 Function definitions are restructured here. Each is assumed to be recursive
335 initially, and non recursive definitions are discovered by the dependency
339 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
340 -- The mysterious SigConverter converts Sigs to ClassOpSigs
341 -- in class declarations. Mostly it's just an identity function
343 cvBinds sig_cvtr binding
344 = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
345 MonoBind mbs sigs Recursive
350 cvMonoBindsAndSigs :: SigConverter
352 -> (RdrNameMonoBinds, [RdrNameSig])
354 cvMonoBindsAndSigs sig_cvtr fb
355 = mangle_bind (EmptyMonoBinds, []) fb
357 mangle_bind acc RdrNullBind
360 mangle_bind acc (RdrAndBindings fb1 fb2)
361 = mangle_bind (mangle_bind acc fb1) fb2
363 mangle_bind (b_acc, s_acc) (RdrSig sig)
364 = (b_acc, sig_cvtr sig : s_acc)
366 mangle_bind (b_acc, s_acc) (RdrValBinding binding)
367 = (b_acc `AndMonoBinds` binding, s_acc)
371 %************************************************************************
373 \subsection[PrefixToHS-utils]{Utilities for conversion}
375 %************************************************************************
377 Separate declarations into all the various kinds:
380 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
383 (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
385 (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
387 go acc RdrNullBind = acc
388 go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
389 go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
390 go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
391 go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
392 go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)