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 extractRuleBndrsTyVars,
48 extractHsCtxtRdrTyVars, extractGenericPatTyVars,
50 mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
51 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 ( minusName, negateName, fromIntegerName, fromRationalName )
68 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
70 import BasicTypes ( RecFlag(..) )
71 import Class ( DefMeth (..) )
75 %************************************************************************
77 \subsection{Type synonyms}
79 %************************************************************************
82 type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
83 type RdrNameBangType = BangType RdrName
84 type RdrNameClassOpSig = Sig RdrName
85 type RdrNameConDecl = ConDecl RdrName
86 type RdrNameConDetails = ConDetails RdrName
87 type RdrNameContext = HsContext RdrName
88 type RdrNameHsDecl = HsDecl RdrName RdrNamePat
89 type RdrNameDefaultDecl = DefaultDecl RdrName
90 type RdrNameForeignDecl = ForeignDecl RdrName
91 type RdrNameGRHS = GRHS RdrName RdrNamePat
92 type RdrNameGRHSs = GRHSs RdrName RdrNamePat
93 type RdrNameHsBinds = HsBinds RdrName RdrNamePat
94 type RdrNameHsExpr = HsExpr RdrName RdrNamePat
95 type RdrNameHsModule = HsModule RdrName RdrNamePat
96 type RdrNameIE = IE RdrName
97 type RdrNameImportDecl = ImportDecl RdrName
98 type RdrNameInstDecl = InstDecl RdrName RdrNamePat
99 type RdrNameMatch = Match RdrName RdrNamePat
100 type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
101 type RdrNamePat = InPat RdrName
102 type RdrNameHsType = HsType RdrName
103 type RdrNameHsTyVar = HsTyVarBndr RdrName
104 type RdrNameSig = Sig RdrName
105 type RdrNameStmt = Stmt RdrName RdrNamePat
106 type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
108 type RdrNameRuleBndr = RuleBndr RdrName
109 type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
110 type RdrNameDeprecation = DeprecDecl RdrName
111 type RdrNameFixitySig = FixitySig RdrName
113 type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
117 %************************************************************************
119 \subsection{A few functions over HsSyn at RdrName}
121 %************************************************************************
123 @extractHsTyRdrNames@ finds the free variables of a HsType
124 It's used when making the for-alls explicit.
127 extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
128 extractHsTyRdrNames ty = nub (extract_ty ty [])
130 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
131 extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
133 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
134 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
136 go (RuleBndr _) acc = acc
137 go (RuleBndrSig _ ty) acc = extract_ty ty acc
139 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
140 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
141 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
142 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
144 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
146 extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
147 extract_pred (HsIParam n ty) acc = extract_ty ty acc
149 extract_tys tys = foldr extract_ty [] tys
151 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
152 extract_ty (HsListTy ty) acc = extract_ty ty acc
153 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
154 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
155 extract_ty (HsPredTy p) acc = extract_pred p acc
156 extract_ty (HsTyVar tv) acc = tv : acc
157 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
159 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
160 extract_ty (HsNumTy num) acc = acc
162 extract_ty (HsForAllTy (Just tvs) ctxt ty)
164 (filter (`notElem` locals) $
165 extract_ctxt ctxt (extract_ty ty []))
167 locals = hsTyVarNames tvs
169 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
170 -- Get the type variables out of the type patterns in a bunch of
171 -- possibly-generic bindings in a class declaration
172 extractGenericPatTyVars binds
173 = filter isRdrTyVar (nub (get binds []))
175 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
176 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
179 get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
180 get_m other acc = acc
184 %************************************************************************
186 \subsection{Construction functions for Rdr stuff}
188 %************************************************************************
190 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
191 by deriving them from the name of the class. We fill in the names for the
192 tycon and datacon corresponding to the class, by deriving them from the
193 name of the class itself. This saves recording the names in the interface
194 file (which would be equally good).
196 Similarly for mkConDecl, mkClassOpSig and default-method names.
198 *** See "THE NAMING STORY" in HsDecls ****
201 mkClassDecl cxt cname tyvars fds sigs mbinds loc
202 = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
203 tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
204 tcdSysNames = new_names, tcdLoc = loc }
206 cls_occ = rdrNameOcc cname
207 data_occ = mkClassDataConOcc cls_occ
208 dname = mkRdrUnqual data_occ
209 dwname = mkRdrUnqual (mkWorkerOcc data_occ)
210 tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
211 sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
212 | n <- [1..length cxt]]
213 -- We number off the superclass selectors, 1, 2, 3 etc so that we
214 -- can construct names for the selectors. Thus
215 -- class (C a, C b) => D a b where ...
216 -- gives superclass selectors
218 -- (We used to call them D_C, but now we can have two different
219 -- superclasses both called C!)
220 new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
223 mkTyData new_or_data context tname list_var list_con i maybe src
224 = let t_occ = rdrNameOcc tname
225 name1 = mkRdrUnqual (mkGenOcc1 t_occ)
226 name2 = mkRdrUnqual (mkGenOcc2 t_occ)
227 in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
228 tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
229 tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
231 mkClassOpSigDM op ty loc
232 = ClassOpSig op (DefMeth dm_rn) ty loc
234 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
236 mkConDecl cname ex_vars cxt details loc
237 = ConDecl cname wkr_name ex_vars cxt details loc
239 wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
243 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
244 -- If the type checker sees (negate 3#) it will barf, because negate
245 -- can't take an unboxed arg. But that is exactly what it will see when
246 -- we write "-3#". So we have to do the negation right now!
248 -- We also do the same service for boxed literals, because this function
249 -- is also used for patterns (which, remember, are parsed as expressions)
250 -- and pattern don't have negation in them.
252 -- Finally, it's important to represent minBound as minBound, and not
253 -- as (negate (-minBound)), becuase the latter is out of range.
255 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
256 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
257 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
259 mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n)
260 mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
261 mkHsNegApp expr = NegApp expr negateName
264 A useful function for building @OpApps@. The operator is always a
265 variable, and we don't know the fixity yet.
268 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
271 These are the bits of syntax that contain rebindable names
272 See RnEnv.lookupSyntaxName
275 mkHsIntegral i = HsIntegral i fromIntegerName
276 mkHsFractional f = HsFractional f fromRationalName
277 mkNPlusKPat n k = NPlusKPatIn n k minusName
281 %************************************************************************
283 \subsection[rdrBinding]{Bindings straight out of the parser}
285 %************************************************************************
289 = -- On input we use the Empty/And form rather than a list
291 | RdrAndBindings RdrBinding RdrBinding
293 -- Value bindings havn't been united with their
295 | RdrValBinding RdrNameMonoBinds
297 -- Signatures are mysterious; we can't
298 -- tell if its a Sig or a ClassOpSig,
299 -- so we just save the pieces:
302 -- The remainder all fit into the main HsDecl form
303 | RdrHsDecl RdrNameHsDecl
305 type SigConverter = RdrNameSig -> RdrNameSig
312 (Maybe RdrNameHsType)
316 %************************************************************************
318 \subsection[cvDecls]{Convert various top-level declarations}
320 %************************************************************************
322 We make a point not to throw any user-pragma ``sigs'' at
323 these conversion functions:
326 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
330 cvInstDeclSig sig = sig
332 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
333 cvClassOpSig sig = sig
337 %************************************************************************
339 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
341 %************************************************************************
343 Function definitions are restructured here. Each is assumed to be recursive
344 initially, and non recursive definitions are discovered by the dependency
348 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
349 -- The mysterious SigConverter converts Sigs to ClassOpSigs
350 -- in class declarations. Mostly it's just an identity function
352 cvBinds sig_cvtr binding
353 = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
354 MonoBind mbs sigs Recursive
359 cvMonoBindsAndSigs :: SigConverter
361 -> (RdrNameMonoBinds, [RdrNameSig])
363 cvMonoBindsAndSigs sig_cvtr fb
364 = mangle_bind (EmptyMonoBinds, []) fb
366 mangle_bind acc RdrNullBind
369 mangle_bind acc (RdrAndBindings fb1 fb2)
370 = mangle_bind (mangle_bind acc fb1) fb2
372 mangle_bind (b_acc, s_acc) (RdrSig sig)
373 = (b_acc, sig_cvtr sig : s_acc)
375 mangle_bind (b_acc, s_acc) (RdrValBinding binding)
376 = (b_acc `AndMonoBinds` binding, s_acc)
380 %************************************************************************
382 \subsection[PrefixToHS-utils]{Utilities for conversion}
384 %************************************************************************
386 Separate declarations into all the various kinds:
389 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
392 (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
394 (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
396 go acc RdrNullBind = acc
397 go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
398 go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
399 go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
400 go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
401 go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)