Migrate cvs diff from fptools-assoc branch
[ghc-hetmet.git] / compiler / rename / RnTypes.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[RnSource]{Main pass of renamer}
5
6 \begin{code}
7 module RnTypes ( 
8         -- Type related stuff
9         rnHsType, rnLHsType, rnLHsTypes, rnContext,
10         rnHsSigType, rnHsTypeFVs,
11
12         -- Patterns and literals
13         rnLPat, rnPat, rnPatsAndThen,   -- Here because it's not part 
14         rnLit, rnOverLit,               -- of any mutual recursion      
15
16         -- Precence related stuff
17         mkOpAppRn, mkNegAppRn, mkOpFormRn, 
18         checkPrecMatch, checkSectionPrec, 
19         
20         -- Error messages
21         dupFieldErr, patSigErr, checkTupSize
22   ) where
23
24 import DynFlags         ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) )
25
26 import HsSyn
27 import RdrHsSyn         ( extractHsRhoRdrTyVars )
28 import RnHsSyn          ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, 
29                           listTyCon_name
30                         )
31 import RnEnv            ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
32                           lookupLocatedOccRn, lookupLocatedBndrRn,
33                           lookupLocatedGlobalOccRn, bindTyVarsRn, 
34                           lookupFixityRn, lookupTyFixityRn,
35                           mapFvRn, warnUnusedMatches,
36                           newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
37 import TcRnMonad
38 import RdrName          ( RdrName, elemLocalRdrEnv )
39 import PrelNames        ( eqClassName, integralClassName, geName, eqName,
40                           negateName, minusName, lengthPName, indexPName,
41                           plusIntegerName, fromIntegerName, timesIntegerName,
42                           ratioDataConName, fromRationalName )
43 import TypeRep          ( funTyCon )
44 import Constants        ( mAX_TUPLE_SIZE )
45 import Name             ( Name )
46 import SrcLoc           ( SrcSpan, Located(..), unLoc, noLoc, combineLocs )
47 import NameSet
48
49 import Literal          ( inIntRange, inCharRange )
50 import BasicTypes       ( compareFixity, funTyFixity, negateFixity, 
51                           Fixity(..), FixityDirection(..) )
52 import ListSetOps       ( removeDups )
53 import Outputable
54
55 #include "HsVersions.h"
56 \end{code}
57
58 These type renamers are in a separate module, rather than in (say) RnSource,
59 to break several loop.
60
61 %*********************************************************
62 %*                                                      *
63 \subsection{Renaming types}
64 %*                                                      *
65 %*********************************************************
66
67 \begin{code}
68 rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
69 rnHsTypeFVs doc_str ty 
70   = rnLHsType doc_str ty        `thenM` \ ty' ->
71     returnM (ty', extractHsTyNames ty')
72
73 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
74         -- rnHsSigType is used for source-language type signatures,
75         -- which use *implicit* universal quantification.
76 rnHsSigType doc_str ty
77   = rnLHsType (text "In the type signature for" <+> doc_str) ty
78 \end{code}
79
80 rnHsType is here because we call it from loadInstDecl, and I didn't
81 want a gratuitous knot.
82
83 \begin{code}
84 rnLHsType  :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
85 rnLHsType doc = wrapLocM (rnHsType doc)
86
87 rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name)
88
89 rnHsType doc (HsForAllTy Implicit _ ctxt ty)
90         -- Implicit quantifiction in source code (no kinds on tyvars)
91         -- Given the signature  C => T  we universally quantify 
92         -- over FV(T) \ {in-scope-tyvars} 
93   = getLocalRdrEnv              `thenM` \ name_env ->
94     let
95         mentioned = extractHsRhoRdrTyVars ctxt ty
96
97         -- Don't quantify over type variables that are in scope;
98         -- when GlasgowExts is off, there usually won't be any, except for
99         -- class signatures:
100         --      class C a where { op :: a -> a }
101         forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
102         tyvar_bndrs   = userHsTyVarBndrs forall_tyvars
103     in
104     rnForAll doc Implicit tyvar_bndrs ctxt ty
105
106 rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau)
107         -- Explicit quantification.
108         -- Check that the forall'd tyvars are actually 
109         -- mentioned in the type, and produce a warning if not
110   = let
111         mentioned          = map unLoc (extractHsRhoRdrTyVars ctxt tau)
112         forall_tyvar_names = hsLTyVarLocNames forall_tyvars
113
114         -- Explicitly quantified but not mentioned in ctxt or tau
115         warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
116     in
117     mappM_ (forAllWarn doc tau) warn_guys       `thenM_`
118     rnForAll doc Explicit forall_tyvars ctxt tau
119
120 rnHsType doc (HsTyVar tyvar)
121   = lookupOccRn tyvar           `thenM` \ tyvar' ->
122     returnM (HsTyVar tyvar')
123
124 rnHsType doc (HsOpTy ty1 (L loc op) ty2)
125   = setSrcSpan loc (
126       lookupOccRn op                    `thenM` \ op' ->
127       let
128         l_op' = L loc op'
129       in
130       lookupTyFixityRn l_op'            `thenM` \ fix ->
131       rnLHsType doc ty1                 `thenM` \ ty1' ->
132       rnLHsType doc ty2                 `thenM` \ ty2' -> 
133       mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2'
134    )
135
136 rnHsType doc (HsParTy ty)
137   = rnLHsType doc ty            `thenM` \ ty' ->
138     returnM (HsParTy ty')
139
140 rnHsType doc (HsBangTy b ty)
141   = rnLHsType doc ty            `thenM` \ ty' ->
142     returnM (HsBangTy b ty')
143
144 rnHsType doc (HsNumTy i)
145   | i == 1    = returnM (HsNumTy i)
146   | otherwise = addErr err_msg  `thenM_`  returnM (HsNumTy i)
147   where
148     err_msg = ptext SLIT("Only unit numeric type pattern is valid")
149                            
150
151 rnHsType doc (HsFunTy ty1 ty2)
152   = rnLHsType doc ty1   `thenM` \ ty1' ->
153         -- Might find a for-all as the arg of a function type
154     rnLHsType doc ty2   `thenM` \ ty2' ->
155         -- Or as the result.  This happens when reading Prelude.hi
156         -- when we find return :: forall m. Monad m -> forall a. a -> m a
157
158         -- Check for fixity rearrangements
159     mkHsOpTyRn HsFunTy (ppr funTyCon) funTyFixity ty1' ty2'
160
161 rnHsType doc (HsListTy ty)
162   = rnLHsType doc ty                            `thenM` \ ty' ->
163     returnM (HsListTy ty')
164
165 rnHsType doc (HsKindSig ty k)
166   = rnLHsType doc ty                            `thenM` \ ty' ->
167     returnM (HsKindSig ty' k)
168
169 rnHsType doc (HsPArrTy ty)
170   = rnLHsType doc ty                            `thenM` \ ty' ->
171     returnM (HsPArrTy ty')
172
173 -- Unboxed tuples are allowed to have poly-typed arguments.  These
174 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
175 rnHsType doc (HsTupleTy tup_con tys)
176   = mappM (rnLHsType doc) tys           `thenM` \ tys' ->
177     returnM (HsTupleTy tup_con tys')
178
179 rnHsType doc (HsAppTy ty1 ty2)
180   = rnLHsType doc ty1           `thenM` \ ty1' ->
181     rnLHsType doc ty2           `thenM` \ ty2' ->
182     returnM (HsAppTy ty1' ty2')
183
184 rnHsType doc (HsPredTy pred)
185   = rnPred doc pred     `thenM` \ pred' ->
186     returnM (HsPredTy pred')
187
188 rnHsType doc (HsSpliceTy _)
189   = do  { addErr (ptext SLIT("Type splices are not yet implemented"))
190         ; failM }
191
192 rnLHsTypes doc tys = mappM (rnLHsType doc) tys
193 \end{code}
194
195
196 \begin{code}
197 rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
198          -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
199
200 rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty
201         -- One reason for this case is that a type like Int#
202         -- starts off as (HsForAllTy Nothing [] Int), in case
203         -- there is some quantification.  Now that we have quantified
204         -- and discovered there are no type variables, it's nicer to turn
205         -- it into plain Int.  If it were Int# instead of Int, we'd actually
206         -- get an error, because the body of a genuine for-all is
207         -- of kind *.
208
209 rnForAll doc exp forall_tyvars ctxt ty
210   = bindTyVarsRn doc forall_tyvars      $ \ new_tyvars ->
211     rnContext doc ctxt                  `thenM` \ new_ctxt ->
212     rnLHsType doc ty                    `thenM` \ new_ty ->
213     returnM (HsForAllTy exp new_tyvars new_ctxt new_ty)
214         -- Retain the same implicit/explicit flag as before
215         -- so that we can later print it correctly
216 \end{code}
217
218
219 %************************************************************************
220 %*                                                                      *
221         Fixities and precedence parsing
222 %*                                                                      *
223 %************************************************************************
224
225 @mkOpAppRn@ deals with operator fixities.  The argument expressions
226 are assumed to be already correctly arranged.  It needs the fixities
227 recorded in the OpApp nodes, because fixity info applies to the things
228 the programmer actually wrote, so you can't find it out from the Name.
229
230 Furthermore, the second argument is guaranteed not to be another
231 operator application.  Why? Because the parser parses all
232 operator appications left-associatively, EXCEPT negation, which
233 we need to handle specially.
234 Infix types are read in a *right-associative* way, so that
235         a `op` b `op` c
236 is always read in as
237         a `op` (b `op` c)
238
239 mkHsOpTyRn rearranges where necessary.  The two arguments
240 have already been renamed and rearranged.  It's made rather tiresome
241 by the presence of ->, which is a separate syntactic construct.
242
243 \begin{code}
244 ---------------
245 -- Building (ty1 `op1` (ty21 `op2` ty22))
246 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
247            -> SDoc -> Fixity -> LHsType Name -> LHsType Name 
248            -> RnM (HsType Name)
249
250 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
251   = do  { fix2 <- lookupTyFixityRn op2
252         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 
253                       (\t1 t2 -> HsOpTy t1 op2 t2)
254                       (ppr op2) fix2 ty21 ty22 loc2 }
255
256 mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2@(L loc2 (HsFunTy ty21 ty22))
257   = mk_hs_op_ty mk1 pp_op1 fix1 ty1 
258                 HsFunTy (ppr funTyCon) funTyFixity ty21 ty22 loc2
259
260 mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2              -- Default case, no rearrangment
261   = return (mk1 ty1 ty2)
262
263 ---------------
264 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
265             -> SDoc -> Fixity -> LHsType Name
266             -> (LHsType Name -> LHsType Name -> HsType Name)
267             -> SDoc -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
268             -> RnM (HsType Name)
269 mk_hs_op_ty mk1 pp_op1 fix1 ty1 
270             mk2 pp_op2 fix2 ty21 ty22 loc2
271   | nofix_error     = do { addErr (precParseErr (quotes pp_op1,fix1) 
272                                                 (quotes pp_op2,fix2))
273                          ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
274   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
275   | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
276                            new_ty <- mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty21
277                          ; return (mk2 (noLoc new_ty) ty22) }
278   where
279     (nofix_error, associate_right) = compareFixity fix1 fix2
280
281
282 ---------------------------
283 mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
284           -> LHsExpr Name -> Fixity             -- Operator and fixity
285           -> LHsExpr Name                       -- Right operand (not an OpApp, but might
286                                                 -- be a NegApp)
287           -> RnM (HsExpr Name)
288
289 -- (e11 `op1` e12) `op2` e2
290 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
291   | nofix_error
292   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
293     returnM (OpApp e1 op2 fix2 e2)
294
295   | associate_right
296   = mkOpAppRn e12 op2 fix2 e2           `thenM` \ new_e ->
297     returnM (OpApp e11 op1 fix1 (L loc' new_e))
298   where
299     loc'= combineLocs e12 e2
300     (nofix_error, associate_right) = compareFixity fix1 fix2
301
302 ---------------------------
303 --      (- neg_arg) `op` e2
304 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
305   | nofix_error
306   = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))      `thenM_`
307     returnM (OpApp e1 op2 fix2 e2)
308
309   | associate_right
310   = mkOpAppRn neg_arg op2 fix2 e2       `thenM` \ new_e ->
311     returnM (NegApp (L loc' new_e) neg_name)
312   where
313     loc' = combineLocs neg_arg e2
314     (nofix_error, associate_right) = compareFixity negateFixity fix2
315
316 ---------------------------
317 --      e1 `op` - neg_arg
318 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _))       -- NegApp can occur on the right
319   | not associate_right                         -- We *want* right association
320   = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))    `thenM_`
321     returnM (OpApp e1 op1 fix1 e2)
322   where
323     (_, associate_right) = compareFixity fix1 negateFixity
324
325 ---------------------------
326 --      Default case
327 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
328   = ASSERT2( right_op_ok fix (unLoc e2),
329              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
330     )
331     returnM (OpApp e1 op fix e2)
332
333 -- Parser left-associates everything, but 
334 -- derived instances may have correctly-associated things to
335 -- in the right operarand.  So we just check that the right operand is OK
336 right_op_ok fix1 (OpApp _ _ fix2 _)
337   = not error_please && associate_right
338   where
339     (error_please, associate_right) = compareFixity fix1 fix2
340 right_op_ok fix1 other
341   = True
342
343 -- Parser initially makes negation bind more tightly than any other operator
344 -- And "deriving" code should respect this (use HsPar if not)
345 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
346 mkNegAppRn neg_arg neg_name
347   = ASSERT( not_op_app (unLoc neg_arg) )
348     returnM (NegApp neg_arg neg_name)
349
350 not_op_app (OpApp _ _ _ _) = False
351 not_op_app other           = True
352
353 ---------------------------
354 mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
355           -> LHsExpr Name -> Fixity     -- Operator and fixity
356           -> LHsCmdTop Name             -- Right operand (not an infix)
357           -> RnM (HsCmd Name)
358
359 -- (e11 `op1` e12) `op2` e2
360 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
361         op2 fix2 a2
362   | nofix_error
363   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
364     returnM (HsArrForm op2 (Just fix2) [a1, a2])
365
366   | associate_right
367   = mkOpFormRn a12 op2 fix2 a2          `thenM` \ new_c ->
368     returnM (HsArrForm op1 (Just fix1)
369         [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
370         -- TODO: locs are wrong
371   where
372     (nofix_error, associate_right) = compareFixity fix1 fix2
373
374 --      Default case
375 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
376   = returnM (HsArrForm op (Just fix) [arg1, arg2])
377
378
379 --------------------------------------
380 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
381              -> RnM (Pat Name)
382
383 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
384   = lookupFixityRn (unLoc op1)  `thenM` \ fix1 ->
385     let
386         (nofix_error, associate_right) = compareFixity fix1 fix2
387     in
388     if nofix_error then
389         addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))       `thenM_`
390         returnM (ConPatIn op2 (InfixCon p1 p2))
391     else 
392     if associate_right then
393         mkConOpPatRn op2 fix2 p12 p2            `thenM` \ new_p ->
394         returnM (ConPatIn op1 (InfixCon p11 (L loc new_p)))  -- XXX loc right?
395     else
396     returnM (ConPatIn op2 (InfixCon p1 p2))
397
398 mkConOpPatRn op fix p1 p2                       -- Default case, no rearrangment
399   = ASSERT( not_op_pat (unLoc p2) )
400     returnM (ConPatIn op (InfixCon p1 p2))
401
402 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
403 not_op_pat other                       = True
404
405 --------------------------------------
406 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
407         -- True indicates an infix lhs
408         -- See comments with rnExpr (OpApp ...) about "deriving"
409
410 checkPrecMatch False fn match 
411   = returnM ()
412 checkPrecMatch True op (MatchGroup ms _)        
413   = mapM_ check ms                              
414   where
415     check (L _ (Match (p1:p2:_) _ _))
416       = checkPrec op (unLoc p1) False   `thenM_`
417         checkPrec op (unLoc p2) True
418
419     check _ = return () 
420         -- This can happen.  Consider
421         --      a `op` True = ...
422         --      op          = ...
423         -- The infix flag comes from the first binding of the group
424         -- but the second eqn has no args (an error, but not discovered
425         -- until the type checker).  So we don't want to crash on the
426         -- second eqn.
427
428 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
429   = lookupFixityRn op           `thenM` \  op_fix@(Fixity op_prec  op_dir) ->
430     lookupFixityRn (unLoc op1)  `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
431     let
432         inf_ok = op1_prec > op_prec || 
433                  (op1_prec == op_prec &&
434                   (op1_dir == InfixR && op_dir == InfixR && right ||
435                    op1_dir == InfixL && op_dir == InfixL && not right))
436
437         info  = (ppr_op op,  op_fix)
438         info1 = (ppr_op op1, op1_fix)
439         (infol, infor) = if right then (info, info1) else (info1, info)
440     in
441     checkErr inf_ok (precParseErr infol infor)
442
443 checkPrec op pat right
444   = returnM ()
445
446 -- Check precedence of (arg op) or (op arg) respectively
447 -- If arg is itself an operator application, then either
448 --   (a) its precedence must be higher than that of op
449 --   (b) its precedency & associativity must be the same as that of op
450 checkSectionPrec :: FixityDirection -> HsExpr RdrName
451         -> LHsExpr Name -> LHsExpr Name -> RnM ()
452 checkSectionPrec direction section op arg
453   = case unLoc arg of
454         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
455         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
456         other            -> returnM ()
457   where
458     L _ (HsVar op_name) = op
459     go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
460         = lookupFixityRn op_name        `thenM` \ op_fix@(Fixity op_prec _) ->
461           checkErr (op_prec < arg_prec
462                      || op_prec == arg_prec && direction == assoc)
463                   (sectionPrecErr (ppr_op op_name, op_fix)      
464                   (pp_arg_op, arg_fix) section)
465 \end{code}
466
467 Precedence-related error messages
468
469 \begin{code}
470 precParseErr op1 op2 
471   = hang (ptext SLIT("precedence parsing error"))
472       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), 
473                ppr_opfix op2,
474                ptext SLIT("in the same infix expression")])
475
476 sectionPrecErr op arg_op section
477  = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
478          nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
479          nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
480
481 pp_prefix_minus = ptext SLIT("prefix `-'")
482 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
483 ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
484 \end{code}
485
486 %*********************************************************
487 %*                                                      *
488 \subsection{Contexts and predicates}
489 %*                                                      *
490 %*********************************************************
491
492 \begin{code}
493 rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
494 rnContext doc = wrapLocM (rnContext' doc)
495
496 rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
497 rnContext' doc ctxt = mappM (rnLPred doc) ctxt
498
499 rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
500 rnLPred doc  = wrapLocM (rnPred doc)
501
502 rnPred doc (HsClassP clas tys)
503   = lookupOccRn clas            `thenM` \ clas_name ->
504     rnLHsTypes doc tys          `thenM` \ tys' ->
505     returnM (HsClassP clas_name tys')
506
507 rnPred doc (HsIParam n ty)
508   = newIPNameRn n               `thenM` \ name ->
509     rnLHsType doc ty            `thenM` \ ty' ->
510     returnM (HsIParam name ty')
511 \end{code}
512
513
514 *********************************************************
515 *                                                       *
516 \subsection{Patterns}
517 *                                                       *
518 *********************************************************
519
520 \begin{code}
521 rnPatsAndThen :: HsMatchContext Name
522               -> [LPat RdrName] 
523               -> ([LPat Name] -> RnM (a, FreeVars))
524               -> RnM (a, FreeVars)
525 -- Bring into scope all the binders and type variables
526 -- bound by the patterns; then rename the patterns; then
527 -- do the thing inside.
528 --
529 -- Note that we do a single bindLocalsRn for all the
530 -- matches together, so that we spot the repeated variable in
531 --      f x x = 1
532
533 rnPatsAndThen ctxt pats thing_inside
534   = bindPatSigTyVarsFV pat_sig_tys      $
535     bindLocatedLocalsFV doc_pat bndrs   $ \ new_bndrs ->
536     rnLPats pats                        `thenM` \ (pats', pat_fvs) ->
537     thing_inside pats'                  `thenM` \ (res, res_fvs) ->
538
539     let
540         unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs
541     in
542     warnUnusedMatches unused_binders   `thenM_`
543     returnM (res, res_fvs `plusFV` pat_fvs)
544   where
545     pat_sig_tys = collectSigTysFromPats pats
546     bndrs       = collectLocatedPatsBinders pats
547     doc_pat     = ptext SLIT("In") <+> pprMatchContext ctxt
548
549 rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars)
550 rnLPats ps = mapFvRn rnLPat ps
551
552 rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars)
553 rnLPat = wrapLocFstM rnPat
554
555 -- -----------------------------------------------------------------------------
556 -- rnPat
557
558 rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars)
559
560 rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs)
561
562 rnPat (VarPat name)
563   = lookupBndrRn  name                  `thenM` \ vname ->
564     returnM (VarPat vname, emptyFVs)
565
566 rnPat (SigPatIn pat ty)
567   = doptM Opt_GlasgowExts `thenM` \ glaExts ->
568     
569     if glaExts
570     then rnLPat pat             `thenM` \ (pat', fvs1) ->
571          rnHsTypeFVs doc ty     `thenM` \ (ty',  fvs2) ->
572          returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
573
574     else addErr (patSigErr ty)  `thenM_`
575          rnPat (unLoc pat) -- XXX shouldn't throw away the loc
576   where
577     doc = text "In a pattern type-signature"
578     
579 rnPat (LitPat lit) 
580   = rnLit lit   `thenM_` 
581     returnM (LitPat lit, emptyFVs) 
582
583 rnPat (NPat lit mb_neg eq _) 
584   = rnOverLit lit                       `thenM` \ (lit', fvs1) ->
585     (case mb_neg of
586         Nothing -> returnM (Nothing, emptyFVs)
587         Just _  -> lookupSyntaxName negateName  `thenM` \ (neg, fvs) ->
588                    returnM (Just neg, fvs)
589     )                                   `thenM` \ (mb_neg', fvs2) ->
590     lookupSyntaxName eqName             `thenM` \ (eq', fvs3) -> 
591     returnM (NPat lit' mb_neg' eq' placeHolderType, 
592               fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName)  
593         -- Needed to find equality on pattern
594
595 rnPat (NPlusKPat name lit _ _)
596   = rnOverLit lit                       `thenM` \ (lit', fvs1) ->
597     lookupLocatedBndrRn name            `thenM` \ name' ->
598     lookupSyntaxName minusName          `thenM` \ (minus, fvs2) ->
599     lookupSyntaxName geName             `thenM` \ (ge, fvs3) ->
600     returnM (NPlusKPat name' lit' ge minus,
601              fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName)
602         -- The Report says that n+k patterns must be in Integral
603
604 rnPat (LazyPat pat)
605   = rnLPat pat          `thenM` \ (pat', fvs) ->
606     returnM (LazyPat pat', fvs)
607
608 rnPat (BangPat pat)
609   = rnLPat pat          `thenM` \ (pat', fvs) ->
610     returnM (BangPat pat', fvs)
611
612 rnPat (AsPat name pat)
613   = rnLPat pat                  `thenM` \ (pat', fvs) ->
614     lookupLocatedBndrRn name    `thenM` \ vname ->
615     returnM (AsPat vname pat', fvs)
616
617 rnPat (ConPatIn con stuff) = rnConPat con stuff
618
619
620 rnPat (ParPat pat)
621   = rnLPat pat          `thenM` \ (pat', fvs) ->
622     returnM (ParPat pat', fvs)
623
624 rnPat (ListPat pats _)
625   = rnLPats pats                        `thenM` \ (patslist, fvs) ->
626     returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name)
627
628 rnPat (PArrPat pats _)
629   = rnLPats pats                        `thenM` \ (patslist, fvs) ->
630     returnM (PArrPat patslist placeHolderType, 
631               fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
632   where
633     implicit_fvs = mkFVs [lengthPName, indexPName]
634
635 rnPat (TuplePat pats boxed _)
636   = checkTupSize tup_size       `thenM_`
637     rnLPats pats                        `thenM` \ (patslist, fvs) ->
638     returnM (TuplePat patslist boxed placeHolderType, 
639              fvs `addOneFV` tycon_name)
640   where
641     tup_size   = length pats
642     tycon_name = tupleTyCon_name boxed tup_size
643
644 rnPat (TypePat name) =
645     rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
646     returnM (TypePat name', fvs)
647
648 -- -----------------------------------------------------------------------------
649 -- rnConPat
650
651 rnConPat con (PrefixCon pats)
652   = lookupLocatedOccRn con      `thenM` \ con' ->
653     rnLPats pats                `thenM` \ (pats', fvs) ->
654     returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con')
655
656 rnConPat con (RecCon rpats)
657   = lookupLocatedOccRn con      `thenM` \ con' ->
658     rnRpats rpats               `thenM` \ (rpats', fvs) ->
659     returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con')
660
661 rnConPat con (InfixCon pat1 pat2)
662   = lookupLocatedOccRn con                      `thenM` \ con' ->
663     rnLPat pat1                                 `thenM` \ (pat1', fvs1) ->
664     rnLPat pat2                                 `thenM` \ (pat2', fvs2) ->
665     lookupFixityRn (unLoc con')                 `thenM` \ fixity ->
666     mkConOpPatRn con' fixity pat1' pat2'        `thenM` \ pat' ->
667     returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con')
668
669 -- -----------------------------------------------------------------------------
670 -- rnRpats
671
672 rnRpats :: [(Located RdrName, LPat RdrName)]
673         -> RnM ([(Located Name, LPat Name)], FreeVars)
674 rnRpats rpats
675   = mappM_ field_dup_err dup_fields     `thenM_`
676     mapFvRn rn_rpat rpats               `thenM` \ (rpats', fvs) ->
677     returnM (rpats', fvs)
678   where
679     (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ]
680
681     field_dup_err dups = addErr (dupFieldErr "pattern" dups)
682
683     rn_rpat (field, pat)
684       = lookupLocatedGlobalOccRn field  `thenM` \ fieldname ->
685         rnLPat pat                      `thenM` \ (pat', fvs) ->
686         returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname)
687
688 \end{code}
689
690
691 %************************************************************************
692 %*                                                                      *
693 \subsubsection{Literals}
694 %*                                                                      *
695 %************************************************************************
696
697 When literals occur we have to make sure
698 that the types and classes they involve
699 are made available.
700
701 \begin{code}
702 rnLit :: HsLit -> RnM ()
703 rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
704 rnLit other      = returnM ()
705
706 rnOverLit (HsIntegral i _)
707   = lookupSyntaxName fromIntegerName    `thenM` \ (from_integer_name, fvs) ->
708     if inIntRange i then
709         returnM (HsIntegral i from_integer_name, fvs)
710     else let
711         extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
712         -- Big integer literals are built, using + and *, 
713         -- out of small integers (DsUtils.mkIntegerLit)
714         -- [NB: plusInteger, timesInteger aren't rebindable... 
715         --      they are used to construct the argument to fromInteger, 
716         --      which is the rebindable one.]
717     in
718     returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
719
720 rnOverLit (HsFractional i _)
721   = lookupSyntaxName fromRationalName           `thenM` \ (from_rat_name, fvs) ->
722     let
723         extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
724         -- We have to make sure that the Ratio type is imported with
725         -- its constructor, because literals of type Ratio t are
726         -- built with that constructor.
727         -- The Rational type is needed too, but that will come in
728         -- as part of the type for fromRational.
729         -- The plus/times integer operations may be needed to construct the numerator
730         -- and denominator (see DsUtils.mkIntegerLit)
731     in
732     returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
733 \end{code}
734
735
736
737 %*********************************************************
738 %*                                                      *
739 \subsection{Errors}
740 %*                                                      *
741 %*********************************************************
742
743 \begin{code}
744 checkTupSize :: Int -> RnM ()
745 checkTupSize tup_size
746   | tup_size <= mAX_TUPLE_SIZE 
747   = returnM ()
748   | otherwise                  
749   = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"),
750                  nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)),
751                  nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))])
752
753 forAllWarn doc ty (L loc tyvar)
754   = ifOptM Opt_WarnUnusedMatches        $
755     addWarnAt loc (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
756                         nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
757                    $$
758                    doc)
759
760 bogusCharError c
761   = ptext SLIT("character literal out of range: '\\") <> char c  <> char '\''
762
763 patSigErr ty
764   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
765         $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
766
767 dupFieldErr str dup
768   = hsep [ptext SLIT("duplicate field name"), 
769           quotes (ppr dup),
770           ptext SLIT("in record"), text str]
771 \end{code}