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