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 RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
73 import BasicTypes ( RecFlag(..) )
74 import Class ( DefMeth (..) )
78 %************************************************************************
80 \subsection{Type synonyms}
82 %************************************************************************
85 type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
86 type RdrNameBangType = BangType RdrName
87 type RdrNameClassOpSig = Sig RdrName
88 type RdrNameConDecl = ConDecl RdrName
89 type RdrNameConDetails = ConDetails RdrName
90 type RdrNameContext = HsContext RdrName
91 type RdrNameHsDecl = HsDecl RdrName RdrNamePat
92 type RdrNameDefaultDecl = DefaultDecl RdrName
93 type RdrNameForeignDecl = ForeignDecl RdrName
94 type RdrNameGRHS = GRHS RdrName RdrNamePat
95 type RdrNameGRHSs = GRHSs RdrName RdrNamePat
96 type RdrNameHsBinds = HsBinds RdrName RdrNamePat
97 type RdrNameHsExpr = HsExpr RdrName RdrNamePat
98 type RdrNameHsModule = HsModule RdrName RdrNamePat
99 type RdrNameIE = IE RdrName
100 type RdrNameImportDecl = ImportDecl RdrName
101 type RdrNameInstDecl = InstDecl RdrName RdrNamePat
102 type RdrNameMatch = Match RdrName RdrNamePat
103 type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
104 type RdrNamePat = InPat RdrName
105 type RdrNameHsType = HsType RdrName
106 type RdrNameHsTyVar = HsTyVarBndr RdrName
107 type RdrNameSig = Sig RdrName
108 type RdrNameStmt = Stmt RdrName RdrNamePat
109 type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
111 type RdrNameRuleBndr = RuleBndr RdrName
112 type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
113 type RdrNameDeprecation = DeprecDecl RdrName
114 type RdrNameFixitySig = FixitySig RdrName
116 type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
120 %************************************************************************
122 \subsection{A few functions over HsSyn at RdrName}
124 %************************************************************************
126 @extractHsTyRdrNames@ finds the free variables of a HsType
127 It's used when making the for-alls explicit.
130 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
131 extractHsTyRdrNames ty = nub (extract_ty ty [])
133 extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
134 extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
136 extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName]
137 extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys))
139 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
140 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
142 go (RuleBndr _) acc = acc
143 go (RuleBndrSig _ ty) acc = extract_ty ty acc
145 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
146 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
147 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
148 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
150 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
152 extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
153 extract_pred (HsIParam n ty) acc = extract_ty ty acc
155 extract_tys tys = foldr extract_ty [] tys
157 extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
158 extract_ty (HsListTy ty) acc = extract_ty ty acc
159 extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
160 extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
161 extract_ty (HsPredTy p) acc = extract_pred p acc
162 extract_ty (HsTyVar tv) acc = tv : acc
163 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
165 extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
166 extract_ty (HsNumTy num) acc = acc
168 extract_ty (HsForAllTy (Just tvs) ctxt ty)
170 (filter (`notElem` locals) $
171 extract_ctxt ctxt (extract_ty ty []))
173 locals = hsTyVarNames tvs
176 extractPatsTyVars :: [RdrNamePat] -> [RdrName]
177 extractPatsTyVars = filter isRdrTyVar .
180 collectSigTysFromPats
182 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
183 -- Get the type variables out of the type patterns in a bunch of
184 -- possibly-generic bindings in a class declaration
185 extractGenericPatTyVars binds
186 = filter isRdrTyVar (nub (get binds []))
188 get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc)
189 get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
192 get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
193 get_m other acc = acc
197 %************************************************************************
199 \subsection{Construction functions for Rdr stuff}
201 %************************************************************************
203 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
204 by deriving them from the name of the class. We fill in the names for the
205 tycon and datacon corresponding to the class, by deriving them from the
206 name of the class itself. This saves recording the names in the interface
207 file (which would be equally good).
209 Similarly for mkConDecl, mkClassOpSig and default-method names.
211 *** See "THE NAMING STORY" in HsDecls ****
214 mkClassDecl cxt cname tyvars fds sigs mbinds loc
215 = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
216 tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
217 tcdSysNames = new_names, tcdLoc = loc }
219 cls_occ = rdrNameOcc cname
220 data_occ = mkClassDataConOcc cls_occ
221 dname = mkRdrUnqual data_occ
222 dwname = mkRdrUnqual (mkWorkerOcc data_occ)
223 tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
224 sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
225 | n <- [1..length cxt]]
226 -- We number off the superclass selectors, 1, 2, 3 etc so that we
227 -- can construct names for the selectors. Thus
228 -- class (C a, C b) => D a b where ...
229 -- gives superclass selectors
231 -- (We used to call them D_C, but now we can have two different
232 -- superclasses both called C!)
233 new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
236 mkTyData new_or_data context tname list_var list_con i maybe src
237 = let t_occ = rdrNameOcc tname
238 name1 = mkRdrUnqual (mkGenOcc1 t_occ)
239 name2 = mkRdrUnqual (mkGenOcc2 t_occ)
240 in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
241 tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
242 tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
244 mkClassOpSigDM op ty loc
245 = ClassOpSig op (DefMeth dm_rn) ty loc
247 dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
249 mkConDecl cname ex_vars cxt details loc
250 = ConDecl cname wkr_name ex_vars cxt details loc
252 wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
256 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
257 -- If the type checker sees (negate 3#) it will barf, because negate
258 -- can't take an unboxed arg. But that is exactly what it will see when
259 -- we write "-3#". So we have to do the negation right now!
261 -- We also do the same service for boxed literals, because this function
262 -- is also used for patterns (which, remember, are parsed as expressions)
263 -- and pattern don't have negation in them.
265 -- Finally, it's important to represent minBound as minBound, and not
266 -- as (negate (-minBound)), becuase the latter is out of range.
268 mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
269 mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
270 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
272 mkHsNegApp (HsOverLit (HsIntegral i)) = HsOverLit (HsIntegral (-i))
273 mkHsNegApp (HsOverLit (HsFractional f)) = HsOverLit (HsFractional (-f))
274 mkHsNegApp expr = NegApp expr
277 A useful function for building @OpApps@. The operator is always a
278 variable, and we don't know the fixity yet.
281 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
285 %************************************************************************
287 \subsection[rdrBinding]{Bindings straight out of the parser}
289 %************************************************************************
293 = -- On input we use the Empty/And form rather than a list
295 | RdrAndBindings RdrBinding RdrBinding
297 -- Value bindings havn't been united with their
299 | RdrValBinding RdrNameMonoBinds
301 -- Signatures are mysterious; we can't
302 -- tell if its a Sig or a ClassOpSig,
303 -- so we just save the pieces:
306 -- The remainder all fit into the main HsDecl form
307 | RdrHsDecl RdrNameHsDecl
309 type SigConverter = RdrNameSig -> RdrNameSig
316 (Maybe RdrNameHsType)
320 %************************************************************************
322 \subsection[cvDecls]{Convert various top-level declarations}
324 %************************************************************************
326 We make a point not to throw any user-pragma ``sigs'' at
327 these conversion functions:
330 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
334 cvInstDeclSig sig = sig
336 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
337 cvClassOpSig sig = sig
341 %************************************************************************
343 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
345 %************************************************************************
347 Function definitions are restructured here. Each is assumed to be recursive
348 initially, and non recursive definitions are discovered by the dependency
352 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
353 -- The mysterious SigConverter converts Sigs to ClassOpSigs
354 -- in class declarations. Mostly it's just an identity function
356 cvBinds sig_cvtr binding
357 = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
358 MonoBind mbs sigs Recursive
363 cvMonoBindsAndSigs :: SigConverter
365 -> (RdrNameMonoBinds, [RdrNameSig])
367 cvMonoBindsAndSigs sig_cvtr fb
368 = mangle_bind (EmptyMonoBinds, []) fb
370 mangle_bind acc RdrNullBind
373 mangle_bind acc (RdrAndBindings fb1 fb2)
374 = mangle_bind (mangle_bind acc fb1) fb2
376 mangle_bind (b_acc, s_acc) (RdrSig sig)
377 = (b_acc, sig_cvtr sig : s_acc)
379 mangle_bind (b_acc, s_acc) (RdrValBinding binding)
380 = (b_acc `AndMonoBinds` binding, s_acc)
384 %************************************************************************
386 \subsection[PrefixToHS-utils]{Utilities for conversion}
388 %************************************************************************
390 Separate declarations into all the various kinds:
393 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
396 (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
398 (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
400 go acc RdrNullBind = acc
401 go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
402 go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs)
403 go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
404 go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
405 go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)