4b9fe62b0aaaa8dfd5c5ae6eee57de934d7cf17c
[ghc.git] / compiler / rename / RnPat.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[RnPat]{Renaming of patterns}
5
6 Basically dependency analysis.
7
8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
9 general, all of these functions return a renamed thing, and a set of
10 free variables.
11
12 \begin{code}
13 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
14
15 module RnPat (-- main entry points
16               rnPat, rnPats, rnBindPat, rnPatAndThen,
17
18               NameMaker, applyNameMaker,     -- a utility for making names:
19               localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,
20                                              --   sometimes we want to make top (qualified) names.
21               isTopRecNameMaker,
22
23               rnHsRecFields, HsRecFieldContext(..),
24
25               -- CpsRn monad
26               CpsRn, liftCps,
27
28               -- Literals
29               rnLit, rnOverLit,
30
31              -- Pattern Error messages that are also used elsewhere
32              checkTupSize, patSigErr
33              ) where
34
35 -- ENH: thin imports to only what is necessary for patterns
36
37 import {-# SOURCE #-} RnExpr ( rnLExpr )
38 import {-# SOURCE #-} RnSplice ( rnSplicePat )
39 import {-# SOURCE #-} TcSplice ( runQuasiQuotePat )
40
41 #include "HsVersions.h"
42
43 import HsSyn            
44 import TcRnMonad
45 import TcHsSyn             ( hsOverLitName )
46 import RnEnv
47 import RnTypes
48 import DynFlags
49 import PrelNames
50 import TyCon               ( tyConName )
51 import ConLike
52 import DataCon             ( dataConTyCon )
53 import TypeRep             ( TyThing(..) )
54 import Name
55 import NameSet
56 import RdrName
57 import BasicTypes
58 import Util
59 import ListSetOps          ( removeDups )
60 import Outputable
61 import SrcLoc
62 import FastString
63 import Literal             ( inCharRange )
64 import TysWiredIn          ( nilDataCon )
65 import DataCon             ( dataConName )
66 import Control.Monad       ( when, liftM, ap )
67 import Data.Ratio
68 \end{code}
69
70
71 %*********************************************************
72 %*                                                      *
73         The CpsRn Monad
74 %*                                                      *
75 %*********************************************************
76
77 Note [CpsRn monad]
78 ~~~~~~~~~~~~~~~~~~
79 The CpsRn monad uses continuation-passing style to support this
80 style of programming:
81
82         do { ...
83            ; ns <- bindNames rs
84            ; ...blah... }
85
86    where rs::[RdrName], ns::[Name]
87
88 The idea is that '...blah...' 
89   a) sees the bindings of ns
90   b) returns the free variables it mentions
91      so that bindNames can report unused ones
92
93 In particular, 
94     mapM rnPatAndThen [p1, p2, p3]
95 has a *left-to-right* scoping: it makes the binders in 
96 p1 scope over p2,p3.
97
98 \begin{code}
99 newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
100                                             -> RnM (r, FreeVars) }
101         -- See Note [CpsRn monad]
102
103 instance Functor CpsRn where
104     fmap = liftM
105
106 instance Applicative CpsRn where
107     pure = return
108     (<*>) = ap
109
110 instance Monad CpsRn where
111   return x = CpsRn (\k -> k x)
112   (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
113
114 runCps :: CpsRn a -> RnM (a, FreeVars)
115 runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
116
117 liftCps :: RnM a -> CpsRn a
118 liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
119
120 liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
121 liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
122                                      ; (r,fvs2) <- k v
123                                      ; return (r, fvs1 `plusFV` fvs2) })
124
125 wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)
126 -- Set the location, and also wrap it around the value returned
127 wrapSrcSpanCps fn (L loc a)
128   = CpsRn (\k -> setSrcSpan loc $ 
129                  unCpsRn (fn a) $ \v -> 
130                  k (L loc v))
131
132 lookupConCps :: Located RdrName -> CpsRn (Located Name)
133 lookupConCps con_rdr 
134   = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr
135                     ; (r, fvs) <- k con_name
136                     ; return (r, addOneFV fvs (unLoc con_name)) })
137     -- We add the constructor name to the free vars
138     -- See Note [Patterns are uses]
139 \end{code}
140
141 Note [Patterns are uses]
142 ~~~~~~~~~~~~~~~~~~~~~~~~
143 Consider
144   module Foo( f, g ) where
145   data T = T1 | T2
146
147   f T1 = True
148   f T2 = False
149
150   g _ = T1
151
152 Arguably we should report T2 as unused, even though it appears in a
153 pattern, because it never occurs in a constructed position.  See
154 Trac #7336.
155 However, implementing this in the face of pattern synonyms would be
156 less straightforward, since given two pattern synonyms
157
158   pattern P1 <- P2
159   pattern P2 <- ()
160
161 we need to observe the dependency between P1 and P2 so that type
162 checking can be done in the correct order (just like for value
163 bindings). Dependencies between bindings is analyzed in the renamer,
164 where we don't know yet whether P2 is a constructor or a pattern
165 synonym. So for now, we do report conid occurrences in patterns as
166 uses.
167
168 %*********************************************************
169 %*                                                      *
170         Name makers
171 %*                                                      *
172 %*********************************************************
173
174 Externally abstract type of name makers,
175 which is how you go from a RdrName to a Name
176
177 \begin{code}
178 data NameMaker 
179   = LamMk       -- Lambdas 
180       Bool      -- True <=> report unused bindings
181                 --   (even if True, the warning only comes out 
182                 --    if -fwarn-unused-matches is on)
183
184   | LetMk       -- Let bindings, incl top level
185                 -- Do *not* check for unused bindings
186       TopLevelFlag
187       MiniFixityEnv
188
189 topRecNameMaker :: MiniFixityEnv -> NameMaker
190 topRecNameMaker fix_env = LetMk TopLevel fix_env
191
192 isTopRecNameMaker :: NameMaker -> Bool
193 isTopRecNameMaker (LetMk TopLevel _) = True
194 isTopRecNameMaker _ = False
195
196 localRecNameMaker :: MiniFixityEnv -> NameMaker
197 localRecNameMaker fix_env = LetMk NotTopLevel fix_env 
198
199 matchNameMaker :: HsMatchContext a -> NameMaker
200 matchNameMaker ctxt = LamMk report_unused
201   where
202     -- Do not report unused names in interactive contexts
203     -- i.e. when you type 'x <- e' at the GHCi prompt
204     report_unused = case ctxt of
205                       StmtCtxt GhciStmtCtxt -> False
206                       -- also, don't warn in pattern quotes, as there
207                       -- is no RHS where the variables can be used!
208                       ThPatQuote            -> False
209                       _                     -> True
210
211 rnHsSigCps :: HsWithBndrs RdrName (LHsType RdrName)
212            -> CpsRn (HsWithBndrs Name (LHsType Name))
213 rnHsSigCps sig 
214   = CpsRn (rnHsBndrSig PatCtx sig)
215
216 newPatName :: NameMaker -> Located RdrName -> CpsRn Name
217 newPatName (LamMk report_unused) rdr_name
218   = CpsRn (\ thing_inside -> 
219         do { name <- newLocalBndrRn rdr_name
220            ; (res, fvs) <- bindLocalNames [name] (thing_inside name)
221            ; when report_unused $ warnUnusedMatches [name] fvs
222            ; return (res, name `delFV` fvs) })
223
224 newPatName (LetMk is_top fix_env) rdr_name
225   = CpsRn (\ thing_inside -> 
226         do { name <- case is_top of
227                        NotTopLevel -> newLocalBndrRn rdr_name
228                        TopLevel    -> newTopSrcBinder rdr_name
229            ; bindLocalNames [name] $       -- Do *not* use bindLocalNameFV here
230                                         -- See Note [View pattern usage]
231              addLocalFixities fix_env [name] $
232              thing_inside name })
233                           
234     -- Note: the bindLocalNames is somewhat suspicious
235     --       because it binds a top-level name as a local name.
236     --       however, this binding seems to work, and it only exists for
237     --       the duration of the patterns and the continuation;
238     --       then the top-level name is added to the global env
239     --       before going on to the RHSes (see RnSource.lhs).
240 \end{code}
241
242 Note [View pattern usage]
243 ~~~~~~~~~~~~~~~~~~~~~~~~~
244 Consider
245   let (r, (r -> x)) = x in ...
246 Here the pattern binds 'r', and then uses it *only* in the view pattern.
247 We want to "see" this use, and in let-bindings we collect all uses and
248 report unused variables at the binding level. So we must use bindLocalNames
249 here, *not* bindLocalNameFV.  Trac #3943.
250
251 %*********************************************************
252 %*                                                      *
253         External entry points
254 %*                                                      *
255 %*********************************************************
256
257 There are various entry points to renaming patterns, depending on
258  (1) whether the names created should be top-level names or local names
259  (2) whether the scope of the names is entirely given in a continuation
260      (e.g., in a case or lambda, but not in a let or at the top-level,
261       because of the way mutually recursive bindings are handled)
262  (3) whether the a type signature in the pattern can bind 
263         lexically-scoped type variables (for unpacking existential 
264         type vars in data constructors)
265  (4) whether we do duplicate and unused variable checking
266  (5) whether there are fixity declarations associated with the names
267      bound by the patterns that need to be brought into scope with them.
268      
269  Rather than burdening the clients of this module with all of these choices,
270  we export the three points in this design space that we actually need:
271
272 \begin{code}
273 -- ----------- Entry point 1: rnPats -------------------
274 -- Binds local names; the scope of the bindings is entirely in the thing_inside
275 --   * allows type sigs to bind type vars
276 --   * local namemaker
277 --   * unused and duplicate checking
278 --   * no fixities
279 rnPats :: HsMatchContext Name -- for error messages
280        -> [LPat RdrName] 
281        -> ([LPat Name] -> RnM (a, FreeVars))
282        -> RnM (a, FreeVars)
283 rnPats ctxt pats thing_inside
284   = do  { envs_before <- getRdrEnvs
285
286           -- (1) rename the patterns, bringing into scope all of the term variables
287           -- (2) then do the thing inside.
288         ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
289         { -- Check for duplicated and shadowed names 
290           -- Must do this *after* renaming the patterns
291           -- See Note [Collect binders only after renaming] in HsUtils
292           -- Because we don't bind the vars all at once, we can't
293           --    check incrementally for duplicates; 
294           -- Nor can we check incrementally for shadowing, else we'll
295           --    complain *twice* about duplicates e.g. f (x,x) = ...
296         ; addErrCtxt doc_pat $ 
297           checkDupAndShadowedNames envs_before $
298           collectPatsBinders pats'
299         ; thing_inside pats' } }
300   where
301     doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt
302
303 rnPat :: HsMatchContext Name -- for error messages
304       -> LPat RdrName 
305       -> (LPat Name -> RnM (a, FreeVars))
306       -> RnM (a, FreeVars)     -- Variables bound by pattern do not 
307                                -- appear in the result FreeVars 
308 rnPat ctxt pat thing_inside 
309   = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
310
311 applyNameMaker :: NameMaker -> Located RdrName -> RnM Name
312 applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatName mk rdr); return n }
313
314 -- ----------- Entry point 2: rnBindPat -------------------
315 -- Binds local names; in a recursive scope that involves other bound vars
316 --      e.g let { (x, Just y) = e1; ... } in ...
317 --   * does NOT allows type sig to bind type vars
318 --   * local namemaker
319 --   * no unused and duplicate checking
320 --   * fixities might be coming in
321 rnBindPat :: NameMaker
322           -> LPat RdrName
323           -> RnM (LPat Name, FreeVars)
324    -- Returned FreeVars are the free variables of the pattern,
325    -- of course excluding variables bound by this pattern 
326
327 rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
328 \end{code}
329
330
331 %*********************************************************
332 %*                                                      *
333         The main event
334 %*                                                      *
335 %*********************************************************
336
337 \begin{code}
338 -- ----------- Entry point 3: rnLPatAndThen -------------------
339 -- General version: parametrized by how you make new names
340
341 rnLPatsAndThen :: NameMaker -> [LPat RdrName] -> CpsRn [LPat Name]
342 rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
343   -- Despite the map, the monad ensures that each pattern binds
344   -- variables that may be mentioned in subsequent patterns in the list
345
346 --------------------
347 -- The workhorse
348 rnLPatAndThen :: NameMaker -> LPat RdrName -> CpsRn (LPat Name)
349 rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
350
351 rnPatAndThen :: NameMaker -> Pat RdrName -> CpsRn (Pat Name)
352 rnPatAndThen _  (WildPat _)   = return (WildPat placeHolderType)
353 rnPatAndThen mk (ParPat pat)  = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') }
354 rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') }
355 rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') }
356 rnPatAndThen mk (VarPat rdr)  = do { loc <- liftCps getSrcSpanM
357                                    ; name <- newPatName mk (L loc rdr)
358                                    ; return (VarPat name) }
359      -- we need to bind pattern variables for view pattern expressions
360      -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
361                                      
362 rnPatAndThen mk (SigPatIn pat sig)
363   -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
364   -- important to rename its type signature _before_ renaming the rest of the
365   -- pattern, so that type variables are first bound by the _outermost_ pattern
366   -- type signature they occur in. This keeps the type checker happy when
367   -- pattern type signatures happen to be nested (#7827)
368   --
369   -- f ((Just (x :: a) :: Maybe a)
370   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^       `a' is first bound here
371   -- ~~~~~~~~~~~~~~~^                   the same `a' then used here
372   = do { sig' <- rnHsSigCps sig
373        ; pat' <- rnLPatAndThen mk pat
374        ; return (SigPatIn pat' sig') }
375        
376 rnPatAndThen mk (LitPat lit)
377   | HsString s <- lit
378   = do { ovlStr <- liftCps (xoptM Opt_OverloadedStrings)
379        ; if ovlStr 
380          then rnPatAndThen mk (mkNPat (mkHsIsString s placeHolderType) Nothing)
381          else normal_lit }
382   | otherwise = normal_lit
383   where
384     normal_lit = do { liftCps (rnLit lit); return (LitPat lit) }
385
386 rnPatAndThen _ (NPat lit mb_neg _eq)
387   = do { lit'    <- liftCpsFV $ rnOverLit lit
388        ; mb_neg' <- liftCpsFV $ case mb_neg of
389                       Nothing -> return (Nothing, emptyFVs)
390                       Just _  -> do { (neg, fvs) <- lookupSyntaxName negateName
391                                     ; return (Just neg, fvs) }
392        ; eq' <- liftCpsFV $ lookupSyntaxName eqName
393        ; return (NPat lit' mb_neg' eq') }
394
395 rnPatAndThen mk (NPlusKPat rdr lit _ _)
396   = do { new_name <- newPatName mk rdr
397        ; lit'  <- liftCpsFV $ rnOverLit lit
398        ; minus <- liftCpsFV $ lookupSyntaxName minusName
399        ; ge    <- liftCpsFV $ lookupSyntaxName geName
400        ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus) }
401                 -- The Report says that n+k patterns must be in Integral
402
403 rnPatAndThen mk (AsPat rdr pat)
404   = do { new_name <- newPatName mk rdr
405        ; pat' <- rnLPatAndThen mk pat
406        ; return (AsPat (L (nameSrcSpan new_name) new_name) pat') }
407
408 rnPatAndThen mk p@(ViewPat expr pat _ty)
409   = do { liftCps $ do { vp_flag <- xoptM Opt_ViewPatterns
410                       ; checkErr vp_flag (badViewPat p) }
411          -- Because of the way we're arranging the recursive calls,
412          -- this will be in the right context 
413        ; expr' <- liftCpsFV $ rnLExpr expr 
414        ; pat' <- rnLPatAndThen mk pat
415        -- Note: at this point the PreTcType in ty can only be a placeHolder
416        -- ; return (ViewPat expr' pat' ty) }
417        ; return (ViewPat expr' pat' placeHolderType) }
418
419 rnPatAndThen mk (ConPatIn con stuff)
420    -- rnConPatAndThen takes care of reconstructing the pattern
421    -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
422   = case unLoc con == nameRdrName (dataConName nilDataCon) of
423       True    -> do { ol_flag <- liftCps $ xoptM Opt_OverloadedLists
424                     ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing)
425                                  else rnConPatAndThen mk con stuff} 
426       False   -> rnConPatAndThen mk con stuff
427
428 rnPatAndThen mk (ListPat pats _ _)
429   = do { opt_OverloadedLists <- liftCps $ xoptM Opt_OverloadedLists
430        ; pats' <- rnLPatsAndThen mk pats
431        ; case opt_OverloadedLists of
432           True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
433                      ; return (ListPat pats' placeHolderType
434                                        (Just (placeHolderType, to_list_name)))}
435           False -> return (ListPat pats' placeHolderType Nothing) }
436
437 rnPatAndThen mk (PArrPat pats _)
438   = do { pats' <- rnLPatsAndThen mk pats
439        ; return (PArrPat pats' placeHolderType) }
440
441 rnPatAndThen mk (TuplePat pats boxed _)
442   = do { liftCps $ checkTupSize (length pats)
443        ; pats' <- rnLPatsAndThen mk pats
444        ; return (TuplePat pats' boxed []) }
445
446 rnPatAndThen mk (SplicePat splice)
447   = do { eith <- liftCpsFV $ rnSplicePat splice
448        ; case eith of   -- See Note [rnSplicePat] in RnSplice
449            Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed
450            Right already_renamed -> return already_renamed } 
451     
452 rnPatAndThen mk (QuasiQuotePat qq)
453   = do { pat <- liftCps $ runQuasiQuotePat qq
454          -- Wrap the result of the quasi-quoter in parens so that we don't
455          -- lose the outermost location set by runQuasiQuote (#7918) 
456        ; rnPatAndThen mk (ParPat pat) }
457
458 rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
459
460
461 --------------------
462 rnConPatAndThen :: NameMaker
463                 -> Located RdrName          -- the constructor
464                 -> HsConPatDetails RdrName 
465                 -> CpsRn (Pat Name)
466
467 rnConPatAndThen mk con (PrefixCon pats)
468   = do  { con' <- lookupConCps con
469         ; pats' <- rnLPatsAndThen mk pats
470         ; return (ConPatIn con' (PrefixCon pats')) }
471
472 rnConPatAndThen mk con (InfixCon pat1 pat2)
473   = do  { con' <- lookupConCps con
474         ; pat1' <- rnLPatAndThen mk pat1
475         ; pat2' <- rnLPatAndThen mk pat2
476         ; fixity <- liftCps $ lookupFixityRn (unLoc con')
477         ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
478
479 rnConPatAndThen mk con (RecCon rpats)
480   = do  { con' <- lookupConCps con
481         ; rpats' <- rnHsRecPatsAndThen mk con' rpats
482         ; return (ConPatIn con' (RecCon rpats')) }
483
484 --------------------
485 rnHsRecPatsAndThen :: NameMaker
486                    -> Located Name      -- Constructor
487                    -> HsRecFields RdrName (LPat RdrName)
488                    -> CpsRn (HsRecFields Name (LPat Name))
489 rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd })
490   = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) VarPat hs_rec_fields
491        ; flds' <- mapM rn_field (flds `zip` [1..])
492        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
493   where 
494     rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n')
495                                                         (hsRecFieldArg fld)
496                                 ; return (L l (fld { hsRecFieldArg = arg' })) }
497
498         -- Suppress unused-match reporting for fields introduced by ".."
499     nested_mk Nothing  mk                    _  = mk
500     nested_mk (Just _) mk@(LetMk {})         _  = mk
501     nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n))
502 \end{code}
503
504
505 %************************************************************************
506 %*                                                                      *
507         Record fields
508 %*                                                                      *
509 %************************************************************************
510
511 \begin{code}
512 data HsRecFieldContext 
513   = HsRecFieldCon Name
514   | HsRecFieldPat Name
515   | HsRecFieldUpd
516
517 rnHsRecFields
518     :: forall arg. 
519        HsRecFieldContext
520     -> (RdrName -> arg) -- When punning, use this to build a new field
521     -> HsRecFields RdrName (Located arg)
522     -> RnM ([LHsRecField Name (Located arg)], FreeVars)
523
524 -- This surprisingly complicated pass
525 --   a) looks up the field name (possibly using disambiguation)
526 --   b) fills in puns and dot-dot stuff
527 -- When we we've finished, we've renamed the LHS, but not the RHS,
528 -- of each x=e binding
529
530 rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
531   = do { pun_ok      <- xoptM Opt_RecordPuns
532        ; disambig_ok <- xoptM Opt_DisambiguateRecordFields
533        ; parent <- check_disambiguation disambig_ok mb_con
534        ; flds1  <- mapM (rn_fld pun_ok parent) flds
535        ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
536        ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
537
538        -- Check for an empty record update  e {}
539        -- NB: don't complain about e { .. }, because rn_dotdot has done that already
540        ; case ctxt of
541            HsRecFieldUpd | Nothing <- dotdot
542                          , null flds
543                          -> addErr emptyUpdateErr
544            _ -> return ()
545
546        ; let all_flds | null dotdot_flds = flds1
547                       | otherwise        = flds1 ++ dotdot_flds
548        ; return (all_flds, mkFVs (getFieldIds all_flds)) }
549   where
550     mb_con = case ctxt of
551                 HsRecFieldCon con | not (isUnboundName con) -> Just con
552                 HsRecFieldPat con | not (isUnboundName con) -> Just con
553                 _ {- update or isUnboundName con -}         -> Nothing
554            -- The unbound name test is because if the constructor 
555            -- isn't in scope the constructor lookup will add an error
556            -- add an error, but still return an unbound name. 
557            -- We don't want that to screw up the dot-dot fill-in stuff.
558
559     doc = case mb_con of
560             Nothing  -> ptext (sLit "constructor field name")
561             Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con)
562
563     rn_fld pun_ok parent (L l (HsRecField { hsRecFieldId = fld
564                                           , hsRecFieldArg = arg
565                                           , hsRecPun = pun }))
566       = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld
567            ; arg' <- if pun 
568                      then do { checkErr pun_ok (badPun fld)
569                              ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) }
570                      else return arg
571            ; return (L l (HsRecField { hsRecFieldId = fld'
572                                      , hsRecFieldArg = arg'
573                                      , hsRecPun = pun })) }
574
575     rn_dotdot :: Maybe Int      -- See Note [DotDot fields] in HsPat
576               -> Maybe Name     -- The constructor (Nothing for an update
577                                 --    or out of scope constructor)
578               -> [LHsRecField Name (Located arg)] -- Explicit fields
579               -> RnM [LHsRecField Name (Located arg)]   -- Filled in .. fields
580     rn_dotdot Nothing _mb_con _flds     -- No ".." at all
581       = return []
582     rn_dotdot (Just {}) Nothing _flds   -- ".." on record update
583       = do { case ctxt of
584                 HsRecFieldUpd -> addErr badDotDotUpd
585                 _             -> return ()
586            ; return [] }
587     rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
588       = ASSERT( n == length flds )
589         do { loc <- getSrcSpanM -- Rather approximate
590            ; dd_flag <- xoptM Opt_RecordWildCards
591            ; checkErr dd_flag (needFlagDotDot ctxt)
592            ; (rdr_env, lcl_env) <- getRdrEnvs
593            ; con_fields <- lookupConstructorFields con
594            ; when (null con_fields) (addErr (badDotDotCon con))
595            ; let present_flds = getFieldIds flds
596                  parent_tc = find_tycon rdr_env con
597
598                    -- For constructor uses (but not patterns)
599                    -- the arg should be in scope (unqualified)
600                    -- ignoring the record field itself
601                    -- Eg.  data R = R { x,y :: Int }
602                    --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}
603                  arg_in_scope fld 
604                    = rdr `elemLocalRdrEnv` lcl_env
605                    || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env
606                                     , case gre_par gre of
607                                         ParentIs p -> p /= parent_tc
608                                         _          -> True ]
609                    where
610                      rdr = mkRdrUnqual (nameOccName fld)
611
612                  dot_dot_gres = [ head gres
613                                 | fld <- con_fields
614                                 , not (fld `elem` present_flds)
615                                 , let gres = lookupGRE_Name rdr_env fld
616                                 , not (null gres)  -- Check field is in scope
617                                 , case ctxt of
618                                     HsRecFieldCon {} -> arg_in_scope fld
619                                     _other           -> True ] 
620
621            ; addUsedRdrNames (map greRdrName dot_dot_gres)
622            ; return [ L loc (HsRecField
623                         { hsRecFieldId  = L loc fld
624                         , hsRecFieldArg = L loc (mk_arg arg_rdr)
625                         , hsRecPun      = False })
626                     | gre <- dot_dot_gres
627                     , let fld     = gre_name gre
628                           arg_rdr = mkRdrUnqual (nameOccName fld) ] }
629
630     check_disambiguation :: Bool -> Maybe Name -> RnM Parent
631     -- When disambiguation is on, 
632     check_disambiguation disambig_ok mb_con
633       | disambig_ok, Just con <- mb_con
634       = do { env <- getGlobalRdrEnv; return (ParentIs (find_tycon env con)) }
635       | otherwise = return NoParent
636  
637     find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Name {- TyCon -}
638     -- Return the parent *type constructor* of the data constructor
639     -- That is, the parent of the data constructor.  
640     -- That's the parent to use for looking up record fields.
641     find_tycon env con 
642       | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con
643       = tyConName (dataConTyCon dc)   -- Special case for [], which is built-in syntax
644                                       -- and not in the GlobalRdrEnv (Trac #8448)
645       | [GRE { gre_par = ParentIs p }] <- lookupGRE_Name env con
646       = p
647
648       | otherwise
649       = pprPanic "find_tycon" (ppr con $$ ppr (lookupGRE_Name env con))
650
651     dup_flds :: [[RdrName]]
652         -- Each list represents a RdrName that occurred more than once
653         -- (the list contains all occurrences)
654         -- Each list in dup_fields is non-empty
655     (_, dup_flds) = removeDups compare (getFieldIds flds)
656
657 getFieldIds :: [LHsRecField id arg] -> [id]
658 getFieldIds flds = map (unLoc . hsRecFieldId . unLoc) flds
659
660 needFlagDotDot :: HsRecFieldContext -> SDoc
661 needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt,
662                             ptext (sLit "Use RecordWildCards to permit this")]
663
664 badDotDotCon :: Name -> SDoc
665 badDotDotCon con
666   = vcat [ ptext (sLit "Illegal `..' notation for constructor") <+> quotes (ppr con)
667          , nest 2 (ptext (sLit "The constructor has no labelled fields")) ]
668
669 badDotDotUpd :: SDoc
670 badDotDotUpd = ptext (sLit "You cannot use `..' in a record update")
671
672 emptyUpdateErr :: SDoc
673 emptyUpdateErr = ptext (sLit "Empty record update")
674
675 badPun :: Located RdrName -> SDoc
676 badPun fld = vcat [ptext (sLit "Illegal use of punning for field") <+> quotes (ppr fld),
677                    ptext (sLit "Use NamedFieldPuns to permit this")]
678
679 dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc
680 dupFieldErr ctxt dups
681   = hsep [ptext (sLit "duplicate field name"), 
682           quotes (ppr (head dups)),
683           ptext (sLit "in record"), pprRFC ctxt]
684
685 pprRFC :: HsRecFieldContext -> SDoc
686 pprRFC (HsRecFieldCon {}) = ptext (sLit "construction")
687 pprRFC (HsRecFieldPat {}) = ptext (sLit "pattern")
688 pprRFC (HsRecFieldUpd {}) = ptext (sLit "update")
689 \end{code}
690
691
692 %************************************************************************
693 %*                                                                      *
694 \subsubsection{Literals}
695 %*                                                                      *
696 %************************************************************************
697
698 When literals occur we have to make sure
699 that the types and classes they involve
700 are made available.
701
702 \begin{code}
703 rnLit :: HsLit -> RnM ()
704 rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
705 rnLit _ = return ()
706
707 -- Turn a Fractional-looking literal which happens to be an integer into an
708 -- Integer-looking literal.
709 generalizeOverLitVal :: OverLitVal -> OverLitVal
710 generalizeOverLitVal (HsFractional (FL {fl_value=val}))
711     | denominator val == 1 = HsIntegral (numerator val)
712 generalizeOverLitVal lit = lit
713
714 rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars)
715 rnOverLit origLit
716   = do  { opt_NumDecimals <- xoptM Opt_NumDecimals
717         ; let { lit@(OverLit {ol_val=val})
718             | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}
719             | otherwise       = origLit
720           }
721         ; let std_name = hsOverLitName val
722         ; (from_thing_name, fvs) <- lookupSyntaxName std_name
723         ; let rebindable = case from_thing_name of
724                                 HsVar v -> v /= std_name
725                                 _       -> panic "rnOverLit"
726         ; return (lit { ol_witness = from_thing_name
727                       , ol_rebindable = rebindable
728                       , ol_type = placeHolderType }, fvs) }
729 \end{code}
730
731 %************************************************************************
732 %*                                                                      *
733 \subsubsection{Errors}
734 %*                                                                      *
735 %************************************************************************
736
737 \begin{code}
738 patSigErr :: Outputable a => a -> SDoc
739 patSigErr ty
740   =  (ptext (sLit "Illegal signature in pattern:") <+> ppr ty)
741         $$ nest 4 (ptext (sLit "Use ScopedTypeVariables to permit it"))
742
743 bogusCharError :: Char -> SDoc
744 bogusCharError c
745   = ptext (sLit "character literal out of range: '\\") <> char c  <> char '\''
746
747 badViewPat :: Pat RdrName -> SDoc
748 badViewPat pat = vcat [ptext (sLit "Illegal view pattern: ") <+> ppr pat,
749                        ptext (sLit "Use ViewPatterns to enable view patterns")]
750 \end{code}