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