[project @ 2001-07-13 13:29:56 by simonpj]
[ghc-hetmet.git] / ghc / compiler / parser / RdrHsSyn.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1996-1998
3 %
4 \section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
5
6 (Well, really, for specialisations involving @RdrName@s, even if
7 they are used somewhat later on in the compiler...)
8
9 \begin{code}
10 module RdrHsSyn (
11         RdrNameArithSeqInfo,
12         RdrNameBangType,
13         RdrNameClassOpSig,
14         RdrNameConDecl,
15         RdrNameConDetails,
16         RdrNameContext,
17         RdrNameDefaultDecl,
18         RdrNameForeignDecl,
19         RdrNameGRHS,
20         RdrNameGRHSs,
21         RdrNameHsBinds,
22         RdrNameHsDecl,
23         RdrNameHsExpr,
24         RdrNameHsModule,
25         RdrNameIE,
26         RdrNameImportDecl,
27         RdrNameInstDecl,
28         RdrNameMatch,
29         RdrNameMonoBinds,
30         RdrNamePat,
31         RdrNameHsType,
32         RdrNameHsTyVar,
33         RdrNameSig,
34         RdrNameStmt,
35         RdrNameTyClDecl,
36         RdrNameRuleDecl,
37         RdrNameRuleBndr,
38         RdrNameDeprecation,
39         RdrNameHsRecordBinds,
40         RdrNameFixitySig,
41
42         RdrBinding(..),
43         RdrMatch(..),
44         SigConverter,
45
46         extractHsTyRdrNames, 
47         extractHsTyRdrTyVars, extractHsTysRdrTyVars,
48         extractRuleBndrsTyVars,
49         extractHsCtxtRdrTyVars, extractGenericPatTyVars,
50  
51         mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
52         mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
53
54         cvBinds,
55         cvMonoBindsAndSigs,
56         cvTopDecls,
57         cvValSig, cvClassOpSig, cvInstDeclSig,
58         mkTyData
59     ) where
60
61 #include "HsVersions.h"
62
63 import HsSyn            -- Lots of it
64 import OccName          ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
65                           mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
66                           mkGenOcc2, 
67                         )
68 import PrelNames        ( minusName, negateName, fromIntegerName, fromRationalName )
69 import RdrName          ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
70                         )
71 import List             ( nub )
72 import BasicTypes       ( RecFlag(..) )
73 import Class            ( DefMeth (..) )
74 \end{code}
75
76  
77 %************************************************************************
78 %*                                                                      *
79 \subsection{Type synonyms}
80 %*                                                                      *
81 %************************************************************************
82
83 \begin{code}
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
109
110 type RdrNameRuleBndr            = RuleBndr              RdrName
111 type RdrNameRuleDecl            = RuleDecl              RdrName RdrNamePat
112 type RdrNameDeprecation         = DeprecDecl            RdrName
113 type RdrNameFixitySig           = FixitySig             RdrName
114
115 type RdrNameHsRecordBinds       = HsRecordBinds         RdrName RdrNamePat
116 \end{code}
117
118
119 %************************************************************************
120 %*                                                                      *
121 \subsection{A few functions over HsSyn at RdrName}
122 %*                                                                    *
123 %************************************************************************
124
125 @extractHsTyRdrNames@ finds the free variables of a HsType
126 It's used when making the for-alls explicit.
127
128 \begin{code}
129 extractHsTyRdrNames :: HsType RdrName -> [RdrName]
130 extractHsTyRdrNames ty = nub (extract_ty ty [])
131
132 extractHsTyRdrTyVars     :: RdrNameHsType -> [RdrName]
133 extractHsTyRdrTyVars ty =  filter isRdrTyVar (extractHsTyRdrNames ty)
134
135 extractHsTysRdrTyVars     :: [RdrNameHsType] -> [RdrName]
136 extractHsTysRdrTyVars tys =  filter isRdrTyVar (nub (extract_tys tys))
137
138 extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
139 extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
140                            where
141                              go (RuleBndr _)       acc = acc
142                              go (RuleBndrSig _ ty) acc = extract_ty ty acc
143
144 extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
145 extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
146 extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
147 extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
148
149 extract_ctxt ctxt acc = foldr extract_pred acc ctxt
150
151 extract_pred (HsClassP cls tys) acc     = foldr extract_ty (cls : acc) tys
152 extract_pred (HsIParam n ty) acc        = extract_ty ty acc
153
154 extract_tys tys = foldr extract_ty [] tys
155
156 extract_ty (HsAppTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
157 extract_ty (HsListTy ty)              acc = extract_ty ty acc
158 extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
159 extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
160 extract_ty (HsPredTy p)               acc = extract_pred p acc
161 extract_ty (HsTyVar tv)               acc = tv : acc
162 extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
163 -- Generics
164 extract_ty (HsOpTy ty1 nam ty2)         acc = extract_ty ty1 (extract_ty ty2 acc)
165 extract_ty (HsNumTy num)              acc = acc
166 -- Generics
167 extract_ty (HsForAllTy (Just tvs) ctxt ty) 
168                                 acc = acc ++
169                                       (filter (`notElem` locals) $
170                                        extract_ctxt ctxt (extract_ty ty []))
171                                     where
172                                       locals = hsTyVarNames tvs
173
174 extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
175 -- Get the type variables out of the type patterns in a bunch of
176 -- possibly-generic bindings in a class declaration
177 extractGenericPatTyVars binds
178   = filter isRdrTyVar (nub (get binds []))
179   where
180     get (AndMonoBinds b1 b2)   acc = get b1 (get b2 acc)
181     get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
182     get other                  acc = acc
183
184     get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
185     get_m other                            acc = acc
186 \end{code}
187
188
189 %************************************************************************
190 %*                                                                      *
191 \subsection{Construction functions for Rdr stuff}
192 %*                                                                    *
193 %************************************************************************
194
195 mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
196 by deriving them from the name of the class.  We fill in the names for the
197 tycon and datacon corresponding to the class, by deriving them from the
198 name of the class itself.  This saves recording the names in the interface
199 file (which would be equally good).
200
201 Similarly for mkConDecl, mkClassOpSig and default-method names.
202
203         *** See "THE NAMING STORY" in HsDecls ****
204   
205 \begin{code}
206 mkClassDecl cxt cname tyvars fds sigs mbinds loc
207   = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
208                 tcdFDs = fds,  tcdSigs = sigs,  tcdMeths = mbinds,
209                 tcdSysNames = new_names, tcdLoc = loc }
210   where
211     cls_occ  = rdrNameOcc cname
212     data_occ = mkClassDataConOcc cls_occ
213     dname    = mkRdrUnqual data_occ
214     dwname   = mkRdrUnqual (mkWorkerOcc data_occ)
215     tname    = mkRdrUnqual (mkClassTyConOcc   cls_occ)
216     sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ) 
217                    | n <- [1..length cxt]]
218       -- We number off the superclass selectors, 1, 2, 3 etc so that we 
219       -- can construct names for the selectors.  Thus
220       --      class (C a, C b) => D a b where ...
221       -- gives superclass selectors
222       --      D_sc1, D_sc2
223       -- (We used to call them D_C, but now we can have two different
224       --  superclasses both called C!)
225     new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
226
227 -- mkTyData :: ??
228 mkTyData new_or_data context tname list_var list_con i maybe src
229   = let t_occ  = rdrNameOcc tname
230         name1 = mkRdrUnqual (mkGenOcc1 t_occ) 
231         name2 = mkRdrUnqual (mkGenOcc2 t_occ) 
232     in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
233                 tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
234                 tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
235
236 mkClassOpSigDM op ty loc
237   = ClassOpSig op (DefMeth dm_rn) ty loc
238   where
239     dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
240
241 mkConDecl cname ex_vars cxt details loc
242   = ConDecl cname wkr_name ex_vars cxt details loc
243   where
244     wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
245 \end{code}
246
247 \begin{code}
248 mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
249 -- If the type checker sees (negate 3#) it will barf, because negate
250 -- can't take an unboxed arg.  But that is exactly what it will see when
251 -- we write "-3#".  So we have to do the negation right now!
252 -- 
253 -- We also do the same service for boxed literals, because this function
254 -- is also used for patterns (which, remember, are parsed as expressions)
255 -- and pattern don't have negation in them.
256 -- 
257 -- Finally, it's important to represent minBound as minBound, and not
258 -- as (negate (-minBound)), becuase the latter is out of range. 
259
260 mkHsNegApp (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))    
261 mkHsNegApp (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))  
262 mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) 
263
264 mkHsNegApp (HsOverLit (HsIntegral   i n)) = HsOverLit (HsIntegral   (-i) n)
265 mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
266 mkHsNegApp expr                           = NegApp expr negateName
267 \end{code}
268
269 A useful function for building @OpApps@.  The operator is always a
270 variable, and we don't know the fixity yet.
271
272 \begin{code}
273 mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
274 \end{code}
275
276 These are the bits of syntax that contain rebindable names
277 See RnEnv.lookupSyntaxName
278
279 \begin{code}
280 mkHsIntegral   i = HsIntegral   i fromIntegerName
281 mkHsFractional f = HsFractional f fromRationalName
282 mkNPlusKPat n k  = NPlusKPatIn n k minusName
283 \end{code}
284
285
286 %************************************************************************
287 %*                                                                      *
288 \subsection[rdrBinding]{Bindings straight out of the parser}
289 %*                                                                      *
290 %************************************************************************
291
292 \begin{code}
293 data RdrBinding
294   =   -- On input we use the Empty/And form rather than a list
295     RdrNullBind
296   | RdrAndBindings    RdrBinding RdrBinding
297
298       -- Value bindings havn't been united with their
299       -- signatures yet
300   | RdrValBinding     RdrNameMonoBinds
301
302       -- Signatures are mysterious; we can't
303       -- tell if its a Sig or a ClassOpSig,
304       -- so we just save the pieces:
305   | RdrSig            RdrNameSig
306
307       -- The remainder all fit into the main HsDecl form
308   | RdrHsDecl         RdrNameHsDecl
309   
310 type SigConverter = RdrNameSig -> RdrNameSig
311 \end{code}
312
313 \begin{code}
314 data RdrMatch
315   = RdrMatch
316              [RdrNamePat]
317              (Maybe RdrNameHsType)
318              RdrNameGRHSs
319 \end{code}
320
321 %************************************************************************
322 %*                                                                      *
323 \subsection[cvDecls]{Convert various top-level declarations}
324 %*                                                                      *
325 %************************************************************************
326
327 We make a point not to throw any user-pragma ``sigs'' at
328 these conversion functions:
329
330 \begin{code}
331 cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
332
333 cvValSig      sig = sig
334
335 cvInstDeclSig sig = sig
336
337 cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
338 cvClassOpSig sig                       = sig
339 \end{code}
340
341
342 %************************************************************************
343 %*                                                                      *
344 \subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
345 %*                                                                      *
346 %************************************************************************
347
348 Function definitions are restructured here. Each is assumed to be recursive
349 initially, and non recursive definitions are discovered by the dependency
350 analyser.
351
352 \begin{code}
353 cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
354         -- The mysterious SigConverter converts Sigs to ClassOpSigs
355         -- in class declarations.  Mostly it's just an identity function
356
357 cvBinds sig_cvtr binding
358   = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
359     MonoBind mbs sigs Recursive
360     }
361 \end{code}
362
363 \begin{code}
364 cvMonoBindsAndSigs :: SigConverter
365                    -> RdrBinding
366                    -> (RdrNameMonoBinds, [RdrNameSig])
367
368 cvMonoBindsAndSigs sig_cvtr fb
369   = mangle_bind (EmptyMonoBinds, []) fb
370   where
371     mangle_bind acc RdrNullBind
372       = acc
373
374     mangle_bind acc (RdrAndBindings fb1 fb2)
375       = mangle_bind (mangle_bind acc fb1) fb2
376
377     mangle_bind (b_acc, s_acc) (RdrSig sig)
378       = (b_acc, sig_cvtr sig : s_acc)
379
380     mangle_bind (b_acc, s_acc) (RdrValBinding binding)
381       = (b_acc `AndMonoBinds` binding, s_acc)
382 \end{code}
383
384
385 %************************************************************************
386 %*                                                                      *
387 \subsection[PrefixToHS-utils]{Utilities for conversion}
388 %*                                                                      *
389 %************************************************************************
390
391 Separate declarations into all the various kinds:
392
393 \begin{code}
394 cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
395 cvTopDecls bind
396   = let
397         (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind 
398     in
399     (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
400   where
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)
407 \end{code}