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,
48 extractRuleBndrsTyVars,
49 extractHsCtxtRdrTyVars, extractGenericPatTyVars,
51 mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
57 cvValSig, cvClassOpSig, cvInstDeclSig,
61 #include "HsVersions.h"
63 import HsSyn -- Lots of it
64 import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
65 mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
68 import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
71 import BasicTypes ( RecFlag(..) )
72 import Class ( DefMeth (..) )
76 %************************************************************************
78 \subsection{Type synonyms}
80 %************************************************************************
83 type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
84 type RdrNameBangType = BangType RdrName
85 type RdrNameClassOpSig = Sig RdrName
86 type RdrNameConDecl = ConDecl RdrName
87 type RdrNameConDetails = ConDetails RdrName
88 type RdrNameContext = HsContext RdrName
89 type RdrNameHsDecl = HsDecl RdrName RdrNamePat
90 type RdrNameDefaultDecl = DefaultDecl RdrName
91 type RdrNameForeignDecl = ForeignDecl RdrName
92 type RdrNameGRHS = GRHS RdrName RdrNamePat
93 type RdrNameGRHSs = GRHSs RdrName RdrNamePat
94 type RdrNameHsBinds = HsBinds RdrName RdrNamePat
95 type RdrNameHsExpr = HsExpr RdrName RdrNamePat
96 type RdrNameHsModule = HsModule RdrName RdrNamePat
97 type RdrNameIE = IE RdrName
98 type RdrNameImportDecl = ImportDecl RdrName
99 type RdrNameInstDecl = InstDecl RdrName RdrNamePat
100 type RdrNameMatch = Match RdrName RdrNamePat
101 type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
102 type RdrNamePat = InPat RdrName
103 type RdrNameHsType = HsType RdrName
104 type RdrNameHsTyVar = HsTyVarBndr RdrName
105 type RdrNameSig = Sig RdrName
106 type RdrNameStmt = Stmt RdrName RdrNamePat
107 type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
109 type RdrNameRuleBndr = RuleBndr RdrName
110 type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
111 type RdrNameDeprecation = DeprecDecl RdrName
112 type RdrNameFixitySig = FixitySig RdrName
114 type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
118 %************************************************************************
120 \subsection{A few functions over HsSyn at RdrName}
122 %************************************************************************
124 @extractHsTyRdrNames@ finds the free variables of a HsType
125 It's used when making the for-alls explicit.
128 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
129 extractHsTyRdrNames ty = nub (extract_ty ty [])
131 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
132 extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
134 extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName]
135 extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys))
137 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
138 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
140 go (RuleBndr _) acc = acc
141 go (RuleBndrSig _ ty) acc = extract_ty ty acc
143 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
144 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
145 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
146 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
148 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
150 extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
151 extract_pred (HsIParam n ty) acc = extract_ty ty acc
153 extract_tys tys = foldr extract_ty [] tys
155 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
156 extract_ty (HsListTy ty) acc = extract_ty ty acc
157 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
158 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
159 extract_ty (HsPredTy p) acc = extract_pred p acc
160 extract_ty (HsTyVar tv) acc = tv : acc
161 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
163 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
164 extract_ty (HsNumTy num) acc = acc
166 extract_ty (HsForAllTy (Just tvs) ctxt ty)
168 (filter (`notElem` locals) $
169 extract_ctxt ctxt (extract_ty ty []))
171 locals = hsTyVarNames tvs
173 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
174 -- Get the type variables out of the type patterns in a bunch of
175 -- possibly-generic bindings in a class declaration
176 extractGenericPatTyVars binds
177 = filter isRdrTyVar (nub (get binds []))
179 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
180 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
183 get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
184 get_m other acc = acc
188 %************************************************************************
190 \subsection{Construction functions for Rdr stuff}
192 %************************************************************************
194 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
195 by deriving them from the name of the class. We fill in the names for the
196 tycon and datacon corresponding to the class, by deriving them from the
197 name of the class itself. This saves recording the names in the interface
198 file (which would be equally good).
200 Similarly for mkConDecl, mkClassOpSig and default-method names.
202 *** See "THE NAMING STORY" in HsDecls ****
205 mkClassDecl cxt cname tyvars fds sigs mbinds loc
206 = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
207 tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
208 tcdSysNames = new_names, tcdLoc = loc }
210 cls_occ = rdrNameOcc cname
211 data_occ = mkClassDataConOcc cls_occ
212 dname = mkRdrUnqual data_occ
213 dwname = mkRdrUnqual (mkWorkerOcc data_occ)
214 tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
215 sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
216 | n <- [1..length cxt]]
217 -- We number off the superclass selectors, 1, 2, 3 etc so that we
218 -- can construct names for the selectors. Thus
219 -- class (C a, C b) => D a b where ...
220 -- gives superclass selectors
222 -- (We used to call them D_C, but now we can have two different
223 -- superclasses both called C!)
224 new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
227 mkTyData new_or_data context tname list_var list_con i maybe src
228 = let t_occ = rdrNameOcc tname
229 name1 = mkRdrUnqual (mkGenOcc1 t_occ)
230 name2 = mkRdrUnqual (mkGenOcc2 t_occ)
231 in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
232 tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
233 tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
235 mkClassOpSigDM op ty loc
236 = ClassOpSig op (DefMeth dm_rn) ty loc
238 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
240 mkConDecl cname ex_vars cxt details loc
241 = ConDecl cname wkr_name ex_vars cxt details loc
243 wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
247 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
248 -- If the type checker sees (negate 3#) it will barf, because negate
249 -- can't take an unboxed arg. But that is exactly what it will see when
250 -- we write "-3#". So we have to do the negation right now!
252 -- We also do the same service for boxed literals, because this function
253 -- is also used for patterns (which, remember, are parsed as expressions)
254 -- and pattern don't have negation in them.
256 -- Finally, it's important to represent minBound as minBound, and not
257 -- as (negate (-minBound)), becuase the latter is out of range.
259 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
260 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
261 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
263 mkHsNegApp (HsOverLit (HsIntegral i)) = HsOverLit (HsIntegral (-i))
264 mkHsNegApp (HsOverLit (HsFractional f)) = HsOverLit (HsFractional (-f))
265 mkHsNegApp expr = NegApp expr
268 A useful function for building @OpApps@. The operator is always a
269 variable, and we don't know the fixity yet.
272 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
276 %************************************************************************
278 \subsection[rdrBinding]{Bindings straight out of the parser}
280 %************************************************************************
284 = -- On input we use the Empty/And form rather than a list
286 | RdrAndBindings RdrBinding RdrBinding
288 -- Value bindings havn't been united with their
290 | RdrValBinding RdrNameMonoBinds
292 -- Signatures are mysterious; we can't
293 -- tell if its a Sig or a ClassOpSig,
294 -- so we just save the pieces:
297 -- The remainder all fit into the main HsDecl form
298 | RdrHsDecl RdrNameHsDecl
300 type SigConverter = RdrNameSig -> RdrNameSig
307 (Maybe RdrNameHsType)
311 %************************************************************************
313 \subsection[cvDecls]{Convert various top-level declarations}
315 %************************************************************************
317 We make a point not to throw any user-pragma ``sigs'' at
318 these conversion functions:
321 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
325 cvInstDeclSig sig = sig
327 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
328 cvClassOpSig sig = sig
332 %************************************************************************
334 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
336 %************************************************************************
338 Function definitions are restructured here. Each is assumed to be recursive
339 initially, and non recursive definitions are discovered by the dependency
343 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
344 -- The mysterious SigConverter converts Sigs to ClassOpSigs
345 -- in class declarations. Mostly it's just an identity function
347 cvBinds sig_cvtr binding
348 = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
349 MonoBind mbs sigs Recursive
354 cvMonoBindsAndSigs :: SigConverter
356 -> (RdrNameMonoBinds, [RdrNameSig])
358 cvMonoBindsAndSigs sig_cvtr fb
359 = mangle_bind (EmptyMonoBinds, []) fb
361 mangle_bind acc RdrNullBind
364 mangle_bind acc (RdrAndBindings fb1 fb2)
365 = mangle_bind (mangle_bind acc fb1) fb2
367 mangle_bind (b_acc, s_acc) (RdrSig sig)
368 = (b_acc, sig_cvtr sig : s_acc)
370 mangle_bind (b_acc, s_acc) (RdrValBinding binding)
371 = (b_acc `AndMonoBinds` binding, s_acc)
375 %************************************************************************
377 \subsection[PrefixToHS-utils]{Utilities for conversion}
379 %************************************************************************
381 Separate declarations into all the various kinds:
384 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
387 (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
389 (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
391 go acc RdrNullBind = acc
392 go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
393 go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
394 go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
395 go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
396 go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)