0ec15a969f9bcda7dc8c7582ee6681a491ea5e67
[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 PrelNames
49 import TyCon ( tyConName )
50 import ConLike
51 import Type ( TyThing(..) )
52 import Name
53 import NameSet
54 import RdrName
55 import BasicTypes
56 import Util
57 import ListSetOps ( removeDups )
58 import Outputable
59 import SrcLoc
60 import Literal ( inCharRange )
61 import TysWiredIn ( nilDataCon )
62 import DataCon
63 import qualified GHC.LanguageExtensions as LangExt
64
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 (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
110
111 runCps :: CpsRn a -> RnM (a, FreeVars)
112 runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
113
114 liftCps :: RnM a -> CpsRn a
115 liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
116
117 liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
118 liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
119 ; (r,fvs2) <- k v
120 ; return (r, fvs1 `plusFV` fvs2) })
121
122 wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)
123 -- Set the location, and also wrap it around the value returned
124 wrapSrcSpanCps fn (L loc a)
125 = CpsRn (\k -> setSrcSpan loc $
126 unCpsRn (fn a) $ \v ->
127 k (L loc v))
128
129 lookupConCps :: Located RdrName -> CpsRn (Located Name)
130 lookupConCps con_rdr
131 = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr
132 ; (r, fvs) <- k con_name
133 ; return (r, addOneFV fvs (unLoc con_name)) })
134 -- We add the constructor name to the free vars
135 -- See Note [Patterns are uses]
136
137 {-
138 Note [Patterns are uses]
139 ~~~~~~~~~~~~~~~~~~~~~~~~
140 Consider
141 module Foo( f, g ) where
142 data T = T1 | T2
143
144 f T1 = True
145 f T2 = False
146
147 g _ = T1
148
149 Arguably we should report T2 as unused, even though it appears in a
150 pattern, because it never occurs in a constructed position. See
151 Trac #7336.
152 However, implementing this in the face of pattern synonyms would be
153 less straightforward, since given two pattern synonyms
154
155 pattern P1 <- P2
156 pattern P2 <- ()
157
158 we need to observe the dependency between P1 and P2 so that type
159 checking can be done in the correct order (just like for value
160 bindings). Dependencies between bindings is analyzed in the renamer,
161 where we don't know yet whether P2 is a constructor or a pattern
162 synonym. So for now, we do report conid occurrences in patterns as
163 uses.
164
165 *********************************************************
166 * *
167 Name makers
168 * *
169 *********************************************************
170
171 Externally abstract type of name makers,
172 which is how you go from a RdrName to a Name
173 -}
174
175 data NameMaker
176 = LamMk -- Lambdas
177 Bool -- True <=> report unused bindings
178 -- (even if True, the warning only comes out
179 -- if -Wunused-matches is on)
180
181 | LetMk -- Let bindings, incl top level
182 -- Do *not* check for unused bindings
183 TopLevelFlag
184 MiniFixityEnv
185
186 topRecNameMaker :: MiniFixityEnv -> NameMaker
187 topRecNameMaker fix_env = LetMk TopLevel fix_env
188
189 isTopRecNameMaker :: NameMaker -> Bool
190 isTopRecNameMaker (LetMk TopLevel _) = True
191 isTopRecNameMaker _ = False
192
193 localRecNameMaker :: MiniFixityEnv -> NameMaker
194 localRecNameMaker fix_env = LetMk NotTopLevel fix_env
195
196 matchNameMaker :: HsMatchContext a -> NameMaker
197 matchNameMaker ctxt = LamMk report_unused
198 where
199 -- Do not report unused names in interactive contexts
200 -- i.e. when you type 'x <- e' at the GHCi prompt
201 report_unused = case ctxt of
202 StmtCtxt GhciStmtCtxt -> False
203 -- also, don't warn in pattern quotes, as there
204 -- is no RHS where the variables can be used!
205 ThPatQuote -> False
206 _ -> True
207
208 rnHsSigCps :: LHsSigWcType RdrName -> CpsRn (LHsSigWcType Name)
209 rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig)
210
211 newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
212 newPatLName name_maker rdr_name@(L loc _)
213 = do { name <- newPatName name_maker rdr_name
214 ; return (L loc name) }
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.hs).
240
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
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 = text "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 (Located Name)
312 applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)
313 ; return n }
314
315 -- ----------- Entry point 2: rnBindPat -------------------
316 -- Binds local names; in a recursive scope that involves other bound vars
317 -- e.g let { (x, Just y) = e1; ... } in ...
318 -- * does NOT allows type sig to bind type vars
319 -- * local namemaker
320 -- * no unused and duplicate checking
321 -- * fixities might be coming in
322 rnBindPat :: NameMaker
323 -> LPat RdrName
324 -> RnM (LPat Name, FreeVars)
325 -- Returned FreeVars are the free variables of the pattern,
326 -- of course excluding variables bound by this pattern
327
328 rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
329
330 {-
331 *********************************************************
332 * *
333 The main event
334 * *
335 *********************************************************
336 -}
337
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 (L l rdr)) = do { loc <- liftCps getSrcSpanM
357 ; name <- newPatName mk (L loc rdr)
358 ; return (VarPat (L l 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 src s <- lit
378 = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
379 ; if ovlStr
380 then rnPatAndThen mk
381 (mkNPat (noLoc (mkHsIsString src s placeHolderType))
382 Nothing)
383 else normal_lit }
384 | otherwise = normal_lit
385 where
386 normal_lit = do { liftCps (rnLit lit); return (LitPat lit) }
387
388 rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)
389 = do { lit' <- liftCpsFV $ rnOverLit lit
390 ; mb_neg' <- liftCpsFV $ case mb_neg of
391 Nothing -> return (Nothing, emptyFVs)
392 Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName
393 ; return (Just neg, fvs) }
394 ; eq' <- liftCpsFV $ lookupSyntaxName eqName
395 ; return (NPat (L l lit') mb_neg' eq' placeHolderType) }
396
397 rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
398 = do { new_name <- newPatName mk rdr
399 ; lit' <- liftCpsFV $ rnOverLit lit
400 ; minus <- liftCpsFV $ lookupSyntaxName minusName
401 ; ge <- liftCpsFV $ lookupSyntaxName geName
402 ; return (NPlusKPat (L (nameSrcSpan new_name) new_name)
403 (L l lit') lit' ge minus placeHolderType) }
404 -- The Report says that n+k patterns must be in Integral
405
406 rnPatAndThen mk (AsPat rdr pat)
407 = do { new_name <- newPatLName mk rdr
408 ; pat' <- rnLPatAndThen mk pat
409 ; return (AsPat new_name pat') }
410
411 rnPatAndThen mk p@(ViewPat expr pat _ty)
412 = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
413 ; checkErr vp_flag (badViewPat p) }
414 -- Because of the way we're arranging the recursive calls,
415 -- this will be in the right context
416 ; expr' <- liftCpsFV $ rnLExpr expr
417 ; pat' <- rnLPatAndThen mk pat
418 -- Note: at this point the PreTcType in ty can only be a placeHolder
419 -- ; return (ViewPat expr' pat' ty) }
420 ; return (ViewPat expr' pat' placeHolderType) }
421
422 rnPatAndThen mk (ConPatIn con stuff)
423 -- rnConPatAndThen takes care of reconstructing the pattern
424 -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
425 = case unLoc con == nameRdrName (dataConName nilDataCon) of
426 True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
427 ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing)
428 else rnConPatAndThen mk con stuff}
429 False -> rnConPatAndThen mk con stuff
430
431 rnPatAndThen mk (ListPat pats _ _)
432 = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
433 ; pats' <- rnLPatsAndThen mk pats
434 ; case opt_OverloadedLists of
435 True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
436 ; return (ListPat pats' placeHolderType
437 (Just (placeHolderType, to_list_name)))}
438 False -> return (ListPat pats' placeHolderType Nothing) }
439
440 rnPatAndThen mk (PArrPat pats _)
441 = do { pats' <- rnLPatsAndThen mk pats
442 ; return (PArrPat pats' placeHolderType) }
443
444 rnPatAndThen mk (TuplePat pats boxed _)
445 = do { liftCps $ checkTupSize (length pats)
446 ; pats' <- rnLPatsAndThen mk pats
447 ; return (TuplePat pats' boxed []) }
448
449 -- If a splice has been run already, just rename the result.
450 rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat)))
451 = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat
452
453 rnPatAndThen mk (SplicePat splice)
454 = do { eith <- liftCpsFV $ rnSplicePat splice
455 ; case eith of -- See Note [rnSplicePat] in RnSplice
456 Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed
457 Right already_renamed -> return already_renamed }
458
459 rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
460
461
462 --------------------
463 rnConPatAndThen :: NameMaker
464 -> Located RdrName -- the constructor
465 -> HsConPatDetails RdrName
466 -> CpsRn (Pat Name)
467
468 rnConPatAndThen mk con (PrefixCon pats)
469 = do { con' <- lookupConCps con
470 ; pats' <- rnLPatsAndThen mk pats
471 ; return (ConPatIn con' (PrefixCon pats')) }
472
473 rnConPatAndThen mk con (InfixCon pat1 pat2)
474 = do { con' <- lookupConCps con
475 ; pat1' <- rnLPatAndThen mk pat1
476 ; pat2' <- rnLPatAndThen mk pat2
477 ; fixity <- liftCps $ lookupFixityRn (unLoc con')
478 ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
479
480 rnConPatAndThen mk con (RecCon rpats)
481 = do { con' <- lookupConCps con
482 ; rpats' <- rnHsRecPatsAndThen mk con' rpats
483 ; return (ConPatIn con' (RecCon rpats')) }
484
485 --------------------
486 rnHsRecPatsAndThen :: NameMaker
487 -> Located Name -- Constructor
488 -> HsRecFields RdrName (LPat RdrName)
489 -> CpsRn (HsRecFields Name (LPat Name))
490 rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd })
491 = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
492 hs_rec_fields
493 ; flds' <- mapM rn_field (flds `zip` [1..])
494 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
495 where
496 mkVarPat l n = VarPat (L l n)
497 rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n')
498 (hsRecFieldArg fld)
499 ; return (L l (fld { hsRecFieldArg = arg' })) }
500
501 -- Suppress unused-match reporting for fields introduced by ".."
502 nested_mk Nothing mk _ = mk
503 nested_mk (Just _) mk@(LetMk {}) _ = mk
504 nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n))
505
506 {-
507 ************************************************************************
508 * *
509 Record fields
510 * *
511 ************************************************************************
512 -}
513
514 data HsRecFieldContext
515 = HsRecFieldCon Name
516 | HsRecFieldPat Name
517 | HsRecFieldUpd
518
519 rnHsRecFields
520 :: forall arg.
521 HsRecFieldContext
522 -> (SrcSpan -> RdrName -> arg)
523 -- When punning, use this to build a new field
524 -> HsRecFields RdrName (Located arg)
525 -> RnM ([LHsRecField Name (Located arg)], FreeVars)
526
527 -- This surprisingly complicated pass
528 -- a) looks up the field name (possibly using disambiguation)
529 -- b) fills in puns and dot-dot stuff
530 -- When we we've finished, we've renamed the LHS, but not the RHS,
531 -- of each x=e binding
532 --
533 -- This is used for record construction and pattern-matching, but not updates.
534
535 rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
536 = do { pun_ok <- xoptM LangExt.RecordPuns
537 ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
538 ; parent <- check_disambiguation disambig_ok mb_con
539 ; flds1 <- mapM (rn_fld pun_ok parent) flds
540 ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
541 ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
542 ; let all_flds | null dotdot_flds = flds1
543 | otherwise = flds1 ++ dotdot_flds
544 ; return (all_flds, mkFVs (getFieldIds all_flds)) }
545 where
546 mb_con = case ctxt of
547 HsRecFieldCon con | not (isUnboundName con) -> Just con
548 HsRecFieldPat con | not (isUnboundName con) -> Just con
549 _ {- update or isUnboundName con -} -> Nothing
550 -- The unbound name test is because if the constructor
551 -- isn't in scope the constructor lookup will add an error
552 -- add an error, but still return an unbound name.
553 -- We don't want that to screw up the dot-dot fill-in stuff.
554
555 doc = case mb_con of
556 Nothing -> text "constructor field name"
557 Just con -> text "field of constructor" <+> quotes (ppr con)
558
559 rn_fld :: Bool -> Maybe Name -> LHsRecField RdrName (Located arg)
560 -> RnM (LHsRecField Name (Located arg))
561 rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl
562 = L loc (FieldOcc (L ll lbl) _)
563 , hsRecFieldArg = arg
564 , hsRecPun = pun }))
565 = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl
566 ; arg' <- if pun
567 then do { checkErr pun_ok (badPun (L loc lbl))
568 -- Discard any module qualifier (#11662)
569 ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
570 ; return (L loc (mk_arg loc arg_rdr)) }
571 else return arg
572 ; return (L l (HsRecField { hsRecFieldLbl
573 = L loc (FieldOcc (L ll lbl) sel)
574 , hsRecFieldArg = arg'
575 , hsRecPun = pun })) }
576
577 rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat
578 -> Maybe Name -- The constructor (Nothing for an
579 -- out of scope constructor)
580 -> [LHsRecField Name (Located arg)] -- Explicit fields
581 -> RnM [LHsRecField Name (Located arg)] -- Filled in .. fields
582 rn_dotdot Nothing _mb_con _flds -- No ".." at all
583 = return []
584 rn_dotdot (Just {}) Nothing _flds -- Constructor out of scope
585 = return []
586 rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
587 = ASSERT( n == length flds )
588 do { loc <- getSrcSpanM -- Rather approximate
589 ; dd_flag <- xoptM LangExt.RecordWildCards
590 ; checkErr dd_flag (needFlagDotDot ctxt)
591 ; (rdr_env, lcl_env) <- getRdrEnvs
592 ; con_fields <- lookupConstructorFields con
593 ; when (null con_fields) (addErr (badDotDotCon con))
594 ; let present_flds = map (occNameFS . rdrNameOcc) $ getFieldLbls flds
595
596 -- For constructor uses (but not patterns)
597 -- the arg should be in scope locally;
598 -- i.e. not top level or imported
599 -- Eg. data R = R { x,y :: Int }
600 -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y}
601 arg_in_scope lbl = mkVarUnqual lbl `elemLocalRdrEnv` lcl_env
602
603 dot_dot_gres = [ (lbl, sel, head gres)
604 | fl <- con_fields
605 , let lbl = flLabel fl
606 , let sel = flSelector fl
607 , not (lbl `elem` present_flds)
608 , let gres = lookupGRE_Field_Name rdr_env sel lbl
609 , not (null gres) -- Check selector is in scope
610 , case ctxt of
611 HsRecFieldCon {} -> arg_in_scope lbl
612 _other -> True ]
613
614 ; addUsedGREs (map thdOf3 dot_dot_gres)
615 ; return [ L loc (HsRecField
616 { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)
617 , hsRecFieldArg = L loc (mk_arg loc arg_rdr)
618 , hsRecPun = False })
619 | (lbl, sel, _) <- dot_dot_gres
620 , let arg_rdr = mkVarUnqual lbl ] }
621
622 check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
623 -- When disambiguation is on, return name of parent tycon.
624 check_disambiguation disambig_ok mb_con
625 | disambig_ok, Just con <- mb_con
626 = do { env <- getGlobalRdrEnv; return (find_tycon env con) }
627 | otherwise = return Nothing
628
629 find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Maybe Name {- TyCon -}
630 -- Return the parent *type constructor* of the data constructor
631 -- (that is, the parent of the data constructor),
632 -- or 'Nothing' if it is a pattern synonym or not in scope.
633 -- That's the parent to use for looking up record fields.
634 find_tycon env con_name
635 | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con_name
636 = Just (tyConName (dataConTyCon dc))
637 -- Special case for [], which is built-in syntax
638 -- and not in the GlobalRdrEnv (Trac #8448)
639
640 | Just gre <- lookupGRE_Name env con_name
641 = case gre_par gre of
642 ParentIs p -> Just p
643 _ -> Nothing -- Can happen if the con_name
644 -- is for a pattern synonym
645
646 | otherwise = Nothing
647 -- Data constructor not lexically in scope at all
648 -- See Note [Disambiguation and Template Haskell]
649
650 dup_flds :: [[RdrName]]
651 -- Each list represents a RdrName that occurred more than once
652 -- (the list contains all occurrences)
653 -- Each list in dup_fields is non-empty
654 (_, dup_flds) = removeDups compare (getFieldLbls flds)
655
656
657 {- Note [Disambiguation and Template Haskell]
658 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
659 Consider (Trac #12130)
660 module Foo where
661 import M
662 b = $(funny)
663
664 module M(funny) where
665 data T = MkT { x :: Int }
666 funny :: Q Exp
667 funny = [| MkT { x = 3 } |]
668
669 When we splice, neither T nor MkT are lexically in scope, so find_tycon will
670 fail. But there is no need for diambiguation anyway, so we just return Nothing
671 -}
672
673 rnHsRecUpdFields
674 :: [LHsRecUpdField RdrName]
675 -> RnM ([LHsRecUpdField Name], FreeVars)
676 rnHsRecUpdFields flds
677 = do { pun_ok <- xoptM LangExt.RecordPuns
678 ; overload_ok <- xoptM LangExt.DuplicateRecordFields
679 ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds
680 ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
681
682 -- Check for an empty record update e {}
683 -- NB: don't complain about e { .. }, because rn_dotdot has done that already
684 ; when (null flds) $ addErr emptyUpdateErr
685
686 ; return (flds1, plusFVs fvss) }
687 where
688 doc = text "constructor field name"
689
690 rn_fld :: Bool -> Bool -> LHsRecUpdField RdrName -> RnM (LHsRecUpdField Name, FreeVars)
691 rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f
692 , hsRecFieldArg = arg
693 , hsRecPun = pun }))
694 = do { let lbl = rdrNameAmbiguousFieldOcc f
695 ; sel <- setSrcSpan loc $
696 -- Defer renaming of overloaded fields to the typechecker
697 -- See Note [Disambiguating record fields] in TcExpr
698 if overload_ok
699 then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl
700 ; case mb of
701 Nothing -> do { addErr (unknownSubordinateErr doc lbl)
702 ; return (Right []) }
703 Just r -> return r }
704 else fmap Left $ lookupGlobalOccRn lbl
705 ; arg' <- if pun
706 then do { checkErr pun_ok (badPun (L loc lbl))
707 -- Discard any module qualifier (#11662)
708 ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
709 ; return (L loc (HsVar (L loc arg_rdr))) }
710 else return arg
711 ; (arg'', fvs) <- rnLExpr arg'
712
713 ; let fvs' = case sel of
714 Left sel_name -> fvs `addOneFV` sel_name
715 Right [FieldOcc _ sel_name] -> fvs `addOneFV` sel_name
716 Right _ -> fvs
717 lbl' = case sel of
718 Left sel_name ->
719 L loc (Unambiguous (L loc lbl) sel_name)
720 Right [FieldOcc lbl sel_name] ->
721 L loc (Unambiguous lbl sel_name)
722 Right _ -> L loc (Ambiguous (L loc lbl) PlaceHolder)
723
724 ; return (L l (HsRecField { hsRecFieldLbl = lbl'
725 , hsRecFieldArg = arg''
726 , hsRecPun = pun }), fvs') }
727
728 dup_flds :: [[RdrName]]
729 -- Each list represents a RdrName that occurred more than once
730 -- (the list contains all occurrences)
731 -- Each list in dup_fields is non-empty
732 (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
733
734
735
736 getFieldIds :: [LHsRecField Name arg] -> [Name]
737 getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds
738
739 getFieldLbls :: [LHsRecField id arg] -> [RdrName]
740 getFieldLbls flds
741 = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
742
743 getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName]
744 getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
745
746 needFlagDotDot :: HsRecFieldContext -> SDoc
747 needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,
748 text "Use RecordWildCards to permit this"]
749
750 badDotDotCon :: Name -> SDoc
751 badDotDotCon con
752 = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)
753 , nest 2 (text "The constructor has no labelled fields") ]
754
755 emptyUpdateErr :: SDoc
756 emptyUpdateErr = text "Empty record update"
757
758 badPun :: Located RdrName -> SDoc
759 badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
760 text "Use NamedFieldPuns to permit this"]
761
762 dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc
763 dupFieldErr ctxt dups
764 = hsep [text "duplicate field name",
765 quotes (ppr (head dups)),
766 text "in record", pprRFC ctxt]
767
768 pprRFC :: HsRecFieldContext -> SDoc
769 pprRFC (HsRecFieldCon {}) = text "construction"
770 pprRFC (HsRecFieldPat {}) = text "pattern"
771 pprRFC (HsRecFieldUpd {}) = text "update"
772
773 {-
774 ************************************************************************
775 * *
776 \subsubsection{Literals}
777 * *
778 ************************************************************************
779
780 When literals occur we have to make sure
781 that the types and classes they involve
782 are made available.
783 -}
784
785 rnLit :: HsLit -> RnM ()
786 rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)
787 rnLit _ = return ()
788
789 -- Turn a Fractional-looking literal which happens to be an integer into an
790 -- Integer-looking literal.
791 generalizeOverLitVal :: OverLitVal -> OverLitVal
792 generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_value=val}))
793 | denominator val == 1 = HsIntegral src (numerator val)
794 generalizeOverLitVal lit = lit
795
796 rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars)
797 rnOverLit origLit
798 = do { opt_NumDecimals <- xoptM LangExt.NumDecimals
799 ; let { lit@(OverLit {ol_val=val})
800 | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}
801 | otherwise = origLit
802 }
803 ; let std_name = hsOverLitName val
804 ; (SyntaxExpr { syn_expr = from_thing_name }, fvs)
805 <- lookupSyntaxName std_name
806 ; let rebindable = case from_thing_name of
807 HsVar (L _ v) -> v /= std_name
808 _ -> panic "rnOverLit"
809 ; return (lit { ol_witness = from_thing_name
810 , ol_rebindable = rebindable
811 , ol_type = placeHolderType }, fvs) }
812
813 {-
814 ************************************************************************
815 * *
816 \subsubsection{Errors}
817 * *
818 ************************************************************************
819 -}
820
821 patSigErr :: Outputable a => a -> SDoc
822 patSigErr ty
823 = (text "Illegal signature in pattern:" <+> ppr ty)
824 $$ nest 4 (text "Use ScopedTypeVariables to permit it")
825
826 bogusCharError :: Char -> SDoc
827 bogusCharError c
828 = text "character literal out of range: '\\" <> char c <> char '\''
829
830 badViewPat :: Pat RdrName -> SDoc
831 badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,
832 text "Use ViewPatterns to enable view patterns"]