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 extractHsTyRdrTyVars, extractHsTysRdrTyVars,
49 extractRuleBndrsTyVars,
50 extractHsCtxtRdrTyVars, extractGenericPatTyVars,
52 mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
58 cvValSig, cvClassOpSig, cvInstDeclSig,
62 #include "HsVersions.h"
64 import HsSyn -- Lots of it
65 import HsPat ( collectSigTysFromPats )
66 import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
67 mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
70 import PrelNames ( negate_RDR )
71 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
74 import BasicTypes ( RecFlag(..) )
75 import Class ( DefMeth (..) )
79 %************************************************************************
81 \subsection{Type synonyms}
83 %************************************************************************
86 type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
87 type RdrNameBangType = BangType RdrName
88 type RdrNameClassOpSig = Sig RdrName
89 type RdrNameConDecl = ConDecl RdrName
90 type RdrNameConDetails = ConDetails RdrName
91 type RdrNameContext = HsContext RdrName
92 type RdrNameHsDecl = HsDecl RdrName RdrNamePat
93 type RdrNameDefaultDecl = DefaultDecl RdrName
94 type RdrNameForeignDecl = ForeignDecl RdrName
95 type RdrNameGRHS = GRHS RdrName RdrNamePat
96 type RdrNameGRHSs = GRHSs RdrName RdrNamePat
97 type RdrNameHsBinds = HsBinds RdrName RdrNamePat
98 type RdrNameHsExpr = HsExpr RdrName RdrNamePat
99 type RdrNameHsModule = HsModule RdrName RdrNamePat
100 type RdrNameIE = IE RdrName
101 type RdrNameImportDecl = ImportDecl RdrName
102 type RdrNameInstDecl = InstDecl RdrName RdrNamePat
103 type RdrNameMatch = Match RdrName RdrNamePat
104 type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
105 type RdrNamePat = InPat RdrName
106 type RdrNameHsType = HsType RdrName
107 type RdrNameHsTyVar = HsTyVarBndr RdrName
108 type RdrNameSig = Sig RdrName
109 type RdrNameStmt = Stmt RdrName RdrNamePat
110 type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
112 type RdrNameRuleBndr = RuleBndr RdrName
113 type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
114 type RdrNameDeprecation = DeprecDecl RdrName
115 type RdrNameFixitySig = FixitySig RdrName
117 type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
121 %************************************************************************
123 \subsection{A few functions over HsSyn at RdrName}
125 %************************************************************************
127 @extractHsTyRdrNames@ finds the free variables of a HsType
128 It's used when making the for-alls explicit.
131 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
132 extractHsTyRdrNames ty = nub (extract_ty ty [])
134 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
135 extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
137 extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName]
138 extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys))
140 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
141 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
143 go (RuleBndr _) acc = acc
144 go (RuleBndrSig _ ty) acc = extract_ty ty acc
146 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
147 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
148 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
149 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
151 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
153 extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys
154 extract_pred (HsPIParam n ty) acc = extract_ty ty acc
156 extract_tys tys = foldr extract_ty [] tys
158 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
159 extract_ty (HsListTy ty) acc = extract_ty ty acc
160 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
161 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
162 extract_ty (HsPredTy p) acc = extract_pred p acc
163 extract_ty (HsTyVar tv) acc = tv : acc
164 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
166 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
167 extract_ty (HsNumTy num) acc = acc
169 extract_ty (HsForAllTy (Just tvs) ctxt ty)
171 (filter (`notElem` locals) $
172 extract_ctxt ctxt (extract_ty ty []))
174 locals = hsTyVarNames tvs
177 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
178 extractPatsTyVars = filter isRdrTyVar .
181 collectSigTysFromPats
183 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
184 -- Get the type variables out of the type patterns in a bunch of
185 -- possibly-generic bindings in a class declaration
186 extractGenericPatTyVars binds
187 = filter isRdrTyVar (nub (get binds []))
189 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
190 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
193 get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
194 get_m other acc = acc
198 %************************************************************************
200 \subsection{Construction functions for Rdr stuff}
202 %************************************************************************
204 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
205 by deriving them from the name of the class. We fill in the names for the
206 tycon and datacon corresponding to the class, by deriving them from the
207 name of the class itself. This saves recording the names in the interface
208 file (which would be equally good).
210 Similarly for mkConDecl, mkClassOpSig and default-method names.
212 *** See "THE NAMING STORY" in HsDecls ****
215 mkClassDecl cxt cname tyvars fds sigs mbinds loc
216 = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
217 tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
218 tcdSysNames = new_names, tcdLoc = loc }
220 cls_occ = rdrNameOcc cname
221 data_occ = mkClassDataConOcc cls_occ
222 dname = mkRdrUnqual data_occ
223 dwname = mkRdrUnqual (mkWorkerOcc data_occ)
224 tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
225 sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
226 | n <- [1..length cxt]]
227 -- We number off the superclass selectors, 1, 2, 3 etc so that we
228 -- can construct names for the selectors. Thus
229 -- class (C a, C b) => D a b where ...
230 -- gives superclass selectors
232 -- (We used to call them D_C, but now we can have two different
233 -- superclasses both called C!)
234 new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
237 mkTyData new_or_data context tname list_var list_con i maybe src
238 = let t_occ = rdrNameOcc tname
239 name1 = mkRdrUnqual (mkGenOcc1 t_occ)
240 name2 = mkRdrUnqual (mkGenOcc2 t_occ)
241 in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
242 tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
243 tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
245 mkClassOpSigDM op ty loc
246 = ClassOpSig op (DefMeth dm_rn) ty loc
248 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
250 mkConDecl cname ex_vars cxt details loc
251 = ConDecl cname wkr_name ex_vars cxt details loc
253 wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
257 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
258 -- If the type checker sees (negate 3#) it will barf, because negate
259 -- can't take an unboxed arg. But that is exactly what it will see when
260 -- we write "-3#". So we have to do the negation right now!
262 -- We also do the same service for boxed literals, because this function
263 -- is also used for patterns (which, remember, are parsed as expressions)
264 -- and pattern don't have negation in them.
266 -- Finally, it's important to represent minBound as minBound, and not
267 -- as (negate (-minBound)), becuase the latter is out of range.
269 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
270 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
271 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
273 mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n)
274 mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
275 mkHsNegApp expr = NegApp expr negate_RDR
278 A useful function for building @OpApps@. The operator is always a
279 variable, and we don't know the fixity yet.
282 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
286 %************************************************************************
288 \subsection[rdrBinding]{Bindings straight out of the parser}
290 %************************************************************************
294 = -- On input we use the Empty/And form rather than a list
296 | RdrAndBindings RdrBinding RdrBinding
298 -- Value bindings havn't been united with their
300 | RdrValBinding RdrNameMonoBinds
302 -- Signatures are mysterious; we can't
303 -- tell if its a Sig or a ClassOpSig,
304 -- so we just save the pieces:
307 -- The remainder all fit into the main HsDecl form
308 | RdrHsDecl RdrNameHsDecl
310 type SigConverter = RdrNameSig -> RdrNameSig
317 (Maybe RdrNameHsType)
321 %************************************************************************
323 \subsection[cvDecls]{Convert various top-level declarations}
325 %************************************************************************
327 We make a point not to throw any user-pragma ``sigs'' at
328 these conversion functions:
331 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
335 cvInstDeclSig sig = sig
337 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
338 cvClassOpSig sig = sig
342 %************************************************************************
344 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
346 %************************************************************************
348 Function definitions are restructured here. Each is assumed to be recursive
349 initially, and non recursive definitions are discovered by the dependency
353 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
354 -- The mysterious SigConverter converts Sigs to ClassOpSigs
355 -- in class declarations. Mostly it's just an identity function
357 cvBinds sig_cvtr binding
358 = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
359 MonoBind mbs sigs Recursive
364 cvMonoBindsAndSigs :: SigConverter
366 -> (RdrNameMonoBinds, [RdrNameSig])
368 cvMonoBindsAndSigs sig_cvtr fb
369 = mangle_bind (EmptyMonoBinds, []) fb
371 mangle_bind acc RdrNullBind
374 mangle_bind acc (RdrAndBindings fb1 fb2)
375 = mangle_bind (mangle_bind acc fb1) fb2
377 mangle_bind (b_acc, s_acc) (RdrSig sig)
378 = (b_acc, sig_cvtr sig : s_acc)
380 mangle_bind (b_acc, s_acc) (RdrValBinding binding)
381 = (b_acc `AndMonoBinds` binding, s_acc)
385 %************************************************************************
387 \subsection[PrefixToHS-utils]{Utilities for conversion}
389 %************************************************************************
391 Separate declarations into all the various kinds:
394 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
397 (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
399 (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
401 go acc RdrNullBind = acc
402 go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
403 go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
404 go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
405 go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
406 go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)