never executed always true always false
1 {-# LANGUAGE TypeApplications #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE RankNTypes #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# LANGUAGE ViewPatterns #-}
8 {-# LANGUAGE DisambiguateRecordFields #-}
9
10 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
11 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
12
13 {-
14 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
15
16 Renaming of patterns
17
18 Basically dependency analysis.
19
20 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
21 general, all of these functions return a renamed thing, and a set of
22 free variables.
23 -}
24 module GHC.Rename.Pat (-- main entry points
25 rnPat, rnPats, rnBindPat, rnPatAndThen,
26
27 NameMaker, applyNameMaker, -- a utility for making names:
28 localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names,
29 -- sometimes we want to make top (qualified) names.
30 isTopRecNameMaker,
31
32 rnHsRecFields, HsRecFieldContext(..),
33 rnHsRecUpdFields,
34
35 -- CpsRn monad
36 CpsRn, liftCps, liftCpsWithCont,
37
38 -- Literals
39 rnLit, rnOverLit,
40 ) where
41
42 -- ENH: thin imports to only what is necessary for patterns
43
44 import GHC.Prelude
45
46 import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
47 import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat )
48
49 import GHC.Hs
50 import GHC.Tc.Errors.Types
51 import GHC.Tc.Utils.Monad
52 import GHC.Tc.Utils.Zonk ( hsOverLitName )
53 import GHC.Rename.Env
54 import GHC.Rename.Fixity
55 import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames
56 , warnUnusedMatches, newLocalBndrRn
57 , checkUnusedRecordWildcard
58 , checkDupNames, checkDupAndShadowedNames
59 , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit )
60 import GHC.Rename.HsType
61 import GHC.Builtin.Names
62 import GHC.Types.Avail ( greNameMangledName )
63 import GHC.Types.Error
64 import GHC.Types.Name
65 import GHC.Types.Name.Set
66 import GHC.Types.Name.Reader
67 import GHC.Types.Basic
68 import GHC.Types.SourceText
69 import GHC.Utils.Misc
70 import GHC.Data.List.SetOps( removeDups )
71 import GHC.Utils.Outputable
72 import GHC.Utils.Panic.Plain
73 import GHC.Types.SrcLoc
74 import GHC.Types.Literal ( inCharRange )
75 import GHC.Builtin.Types ( nilDataCon )
76 import GHC.Core.DataCon
77 import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields )
78 import qualified GHC.LanguageExtensions as LangExt
79
80 import Control.Monad ( when, ap, guard, forM, unless )
81 import qualified Data.List.NonEmpty as NE
82 import Data.Maybe
83 import Data.Ratio
84 import GHC.Types.FieldLabel (DuplicateRecordFields(..))
85
86 {-
87 *********************************************************
88 * *
89 The CpsRn Monad
90 * *
91 *********************************************************
92
93 Note [CpsRn monad]
94 ~~~~~~~~~~~~~~~~~~
95 The CpsRn monad uses continuation-passing style to support this
96 style of programming:
97
98 do { ...
99 ; ns <- bindNames rs
100 ; ...blah... }
101
102 where rs::[RdrName], ns::[Name]
103
104 The idea is that '...blah...'
105 a) sees the bindings of ns
106 b) returns the free variables it mentions
107 so that bindNames can report unused ones
108
109 In particular,
110 mapM rnPatAndThen [p1, p2, p3]
111 has a *left-to-right* scoping: it makes the binders in
112 p1 scope over p2,p3.
113 -}
114
115 newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
116 -> RnM (r, FreeVars) }
117 deriving (Functor)
118 -- See Note [CpsRn monad]
119
120 instance Applicative CpsRn where
121 pure x = CpsRn (\k -> k x)
122 (<*>) = ap
123
124 instance Monad CpsRn where
125 (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
126
127 runCps :: CpsRn a -> RnM (a, FreeVars)
128 runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
129
130 liftCps :: RnM a -> CpsRn a
131 liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
132
133 liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
134 liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
135 ; (r,fvs2) <- k v
136 ; return (r, fvs1 `plusFV` fvs2) })
137
138 liftCpsWithCont :: (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)) -> CpsRn b
139 liftCpsWithCont = CpsRn
140
141 wrapSrcSpanCps :: (a -> CpsRn b) -> LocatedA a -> CpsRn (LocatedA b)
142 -- Set the location, and also wrap it around the value returned
143 wrapSrcSpanCps fn (L loc a)
144 = CpsRn (\k -> setSrcSpanA loc $
145 unCpsRn (fn a) $ \v ->
146 k (L loc v))
147
148 lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name)
149 lookupConCps con_rdr
150 = CpsRn (\k -> do { con_name <- lookupLocatedOccRnConstr con_rdr
151 ; (r, fvs) <- k con_name
152 ; return (r, addOneFV fvs (unLoc con_name)) })
153 -- We add the constructor name to the free vars
154 -- See Note [Patterns are uses]
155
156 {-
157 Note [Patterns are uses]
158 ~~~~~~~~~~~~~~~~~~~~~~~~
159 Consider
160 module Foo( f, g ) where
161 data T = T1 | T2
162
163 f T1 = True
164 f T2 = False
165
166 g _ = T1
167
168 Arguably we should report T2 as unused, even though it appears in a
169 pattern, because it never occurs in a constructed position.
170 See #7336.
171 However, implementing this in the face of pattern synonyms would be
172 less straightforward, since given two pattern synonyms
173
174 pattern P1 <- P2
175 pattern P2 <- ()
176
177 we need to observe the dependency between P1 and P2 so that type
178 checking can be done in the correct order (just like for value
179 bindings). Dependencies between bindings is analyzed in the renamer,
180 where we don't know yet whether P2 is a constructor or a pattern
181 synonym. So for now, we do report conid occurrences in patterns as
182 uses.
183
184 *********************************************************
185 * *
186 Name makers
187 * *
188 *********************************************************
189
190 Externally abstract type of name makers,
191 which is how you go from a RdrName to a Name
192 -}
193
194 data NameMaker
195 = LamMk -- Lambdas
196 Bool -- True <=> report unused bindings
197 -- (even if True, the warning only comes out
198 -- if -Wunused-matches is on)
199
200 | LetMk -- Let bindings, incl top level
201 -- Do *not* check for unused bindings
202 TopLevelFlag
203 MiniFixityEnv
204
205 topRecNameMaker :: MiniFixityEnv -> NameMaker
206 topRecNameMaker fix_env = LetMk TopLevel fix_env
207
208 isTopRecNameMaker :: NameMaker -> Bool
209 isTopRecNameMaker (LetMk TopLevel _) = True
210 isTopRecNameMaker _ = False
211
212 localRecNameMaker :: MiniFixityEnv -> NameMaker
213 localRecNameMaker fix_env = LetMk NotTopLevel fix_env
214
215 matchNameMaker :: HsMatchContext a -> NameMaker
216 matchNameMaker ctxt = LamMk report_unused
217 where
218 -- Do not report unused names in interactive contexts
219 -- i.e. when you type 'x <- e' at the GHCi prompt
220 report_unused = case ctxt of
221 StmtCtxt (HsDoStmt GhciStmtCtxt) -> False
222 -- also, don't warn in pattern quotes, as there
223 -- is no RHS where the variables can be used!
224 ThPatQuote -> False
225 _ -> True
226
227 newPatLName :: NameMaker -> LocatedN RdrName -> CpsRn (LocatedN Name)
228 newPatLName name_maker rdr_name@(L loc _)
229 = do { name <- newPatName name_maker rdr_name
230 ; return (L loc name) }
231
232 newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name
233 newPatName (LamMk report_unused) rdr_name
234 = CpsRn (\ thing_inside ->
235 do { name <- newLocalBndrRn rdr_name
236 ; (res, fvs) <- bindLocalNames [name] (thing_inside name)
237 ; when report_unused $ warnUnusedMatches [name] fvs
238 ; return (res, name `delFV` fvs) })
239
240 newPatName (LetMk is_top fix_env) rdr_name
241 = CpsRn (\ thing_inside ->
242 do { name <- case is_top of
243 NotTopLevel -> newLocalBndrRn rdr_name
244 TopLevel -> newTopSrcBinder rdr_name
245 ; bindLocalNames [name] $
246 -- Do *not* use bindLocalNameFV here;
247 -- see Note [View pattern usage]
248 -- For the TopLevel case
249 -- see Note [bindLocalNames for an External name]
250 addLocalFixities fix_env [name] $
251 thing_inside name })
252
253 {- Note [bindLocalNames for an External name]
254 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
255 In the TopLevel case, the use of bindLocalNames here is somewhat
256 suspicious because it binds a top-level External name in the
257 LocalRdrEnv. c.f. Note [LocalRdrEnv] in GHC.Types.Name.Reader.
258
259 However, this only happens when renaming the LHS (only) of a top-level
260 pattern binding. Even though this only the LHS, we need to bring the
261 binder into scope in the pattern itself in case the binder is used in
262 subsequent view patterns. A bit bizarre, something like
263 (x, Just y <- f x) = e
264
265 Anyway, bindLocalNames does work, and the binding only exists for the
266 duration of the pattern; then the top-level name is added to the
267 global env before going on to the RHSes (see GHC.Rename.Module).
268
269 Note [View pattern usage]
270 ~~~~~~~~~~~~~~~~~~~~~~~~~
271 Consider
272 let (r, (r -> x)) = x in ...
273 Here the pattern binds 'r', and then uses it *only* in the view pattern.
274 We want to "see" this use, and in let-bindings we collect all uses and
275 report unused variables at the binding level. So we must use bindLocalNames
276 here, *not* bindLocalNameFV. #3943.
277
278
279 Note [Don't report shadowing for pattern synonyms]
280 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
281 There is one special context where a pattern doesn't introduce any new binders -
282 pattern synonym declarations. Therefore we don't check to see if pattern
283 variables shadow existing identifiers as they are never bound to anything
284 and have no scope.
285
286 Without this check, there would be quite a cryptic warning that the `x`
287 in the RHS of the pattern synonym declaration shadowed the top level `x`.
288
289 ```
290 x :: ()
291 x = ()
292
293 pattern P x = Just x
294 ```
295
296 See #12615 for some more examples.
297
298 Note [Handling overloaded and rebindable patterns]
299 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
300 Overloaded paterns and rebindable patterns are desugared in the renamer
301 using the HsPatExpansion mechanism detailed in:
302 Note [Rebindable syntax and HsExpansion]
303 The approach is similar to that of expressions, which is further detailed
304 in Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.
305
306 Here are the patterns that are currently desugared in this way:
307
308 * ListPat (list patterns [p1,p2,p3])
309 When (and only when) OverloadedLists is on, desugar to a view pattern:
310 [p1, p2, p3]
311 ==>
312 toList -> [p1, p2, p3]
313 ^^^^^^^^^^^^ built-in (non-overloaded) list pattern
314 NB: the type checker and desugarer still see ListPat,
315 but to them it always means the built-in list pattern.
316 See Note [Desugaring overloaded list patterns] below for more details.
317
318 We expect to add to this list as we deal with more patterns via the expansion
319 mechanism.
320
321 Note [Desugaring overloaded list patterns]
322 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
323 If OverloadedLists is enabled, we desugar a list pattern to a view pattern:
324
325 [p1, p2, p3]
326 ==>
327 toList -> [p1, p2, p3]
328
329 This happens directly in the renamer, using the HsPatExpansion mechanism
330 detailed in Note [Rebindable syntax and HsExpansion].
331
332 Note that we emit a special view pattern: we additionally keep track of an
333 inverse to the pattern.
334 See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn for details.
335
336 == Wrinkle ==
337
338 This is all fine, except in one very specific case:
339 - when RebindableSyntax is off,
340 - and the type being matched on is already a list type.
341
342 In this case, it is undesirable to desugar an overloaded list pattern into
343 a view pattern. To illustrate, consider the following program:
344
345 > {-# LANGUAGE OverloadedLists #-}
346 >
347 > f [] = True
348 > f (_:_) = False
349
350 Without any special logic, the pattern `[]` is desugared to `(toList -> [])`,
351 whereas `(_:_)` remains a constructor pattern. This implies that the argument
352 of `f` is necessarily a list (even though `OverloadedLists` is enabled).
353 After desugaring the overloaded list pattern `[]`, and type-checking, we obtain:
354
355 > f :: [a] -> Bool
356 > f (toList -> []) = True
357 > f (_:_) = False
358
359 The pattern match checker then warns that the pattern `[]` is not covered,
360 as it isn't able to look through view patterns.
361 We can see that this is silly: as we are matching on a list, `toList` doesn't
362 actually do anything. So we ignore it, and desugar the pattern to an explicit
363 list pattern, instead of a view pattern.
364
365 Note however that this is not necessarily sound, because it is possible to have
366 a list `l` such that `toList l` is not the same as `l`.
367 This can happen with an overlapping instance, such as the following:
368
369 instance {-# OVERLAPPING #-} IsList [Int] where
370 type Item [Int] = Int
371 toList = reverse
372 fromList = reverse
373
374 We make the assumption that no such instance exists, in order to avoid worsening
375 pattern-match warnings (see #14547).
376
377 *********************************************************
378 * *
379 External entry points
380 * *
381 *********************************************************
382
383 There are various entry points to renaming patterns, depending on
384 (1) whether the names created should be top-level names or local names
385 (2) whether the scope of the names is entirely given in a continuation
386 (e.g., in a case or lambda, but not in a let or at the top-level,
387 because of the way mutually recursive bindings are handled)
388 (3) whether the a type signature in the pattern can bind
389 lexically-scoped type variables (for unpacking existential
390 type vars in data constructors)
391 (4) whether we do duplicate and unused variable checking
392 (5) whether there are fixity declarations associated with the names
393 bound by the patterns that need to be brought into scope with them.
394
395 Rather than burdening the clients of this module with all of these choices,
396 we export the three points in this design space that we actually need:
397 -}
398
399 -- ----------- Entry point 1: rnPats -------------------
400 -- Binds local names; the scope of the bindings is entirely in the thing_inside
401 -- * allows type sigs to bind type vars
402 -- * local namemaker
403 -- * unused and duplicate checking
404 -- * no fixities
405 rnPats :: HsMatchContext GhcRn -- for error messages
406 -> [LPat GhcPs]
407 -> ([LPat GhcRn] -> RnM (a, FreeVars))
408 -> RnM (a, FreeVars)
409 rnPats ctxt pats thing_inside
410 = do { envs_before <- getRdrEnvs
411
412 -- (1) rename the patterns, bringing into scope all of the term variables
413 -- (2) then do the thing inside.
414 ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
415 { -- Check for duplicated and shadowed names
416 -- Must do this *after* renaming the patterns
417 -- See Note [Collect binders only after renaming] in GHC.Hs.Utils
418 -- Because we don't bind the vars all at once, we can't
419 -- check incrementally for duplicates;
420 -- Nor can we check incrementally for shadowing, else we'll
421 -- complain *twice* about duplicates e.g. f (x,x) = ...
422 --
423 -- See note [Don't report shadowing for pattern synonyms]
424 ; let bndrs = collectPatsBinders CollNoDictBinders pats'
425 ; addErrCtxt doc_pat $
426 if isPatSynCtxt ctxt
427 then checkDupNames bndrs
428 else checkDupAndShadowedNames envs_before bndrs
429 ; thing_inside pats' } }
430 where
431 doc_pat = text "In" <+> pprMatchContext ctxt
432
433 rnPat :: HsMatchContext GhcRn -- for error messages
434 -> LPat GhcPs
435 -> (LPat GhcRn -> RnM (a, FreeVars))
436 -> RnM (a, FreeVars) -- Variables bound by pattern do not
437 -- appear in the result FreeVars
438 rnPat ctxt pat thing_inside
439 = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
440
441 applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name)
442 applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)
443 ; return n }
444
445 -- ----------- Entry point 2: rnBindPat -------------------
446 -- Binds local names; in a recursive scope that involves other bound vars
447 -- e.g let { (x, Just y) = e1; ... } in ...
448 -- * does NOT allows type sig to bind type vars
449 -- * local namemaker
450 -- * no unused and duplicate checking
451 -- * fixities might be coming in
452 rnBindPat :: NameMaker
453 -> LPat GhcPs
454 -> RnM (LPat GhcRn, FreeVars)
455 -- Returned FreeVars are the free variables of the pattern,
456 -- of course excluding variables bound by this pattern
457
458 rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
459
460 {-
461 *********************************************************
462 * *
463 The main event
464 * *
465 *********************************************************
466 -}
467
468 -- ----------- Entry point 3: rnLPatAndThen -------------------
469 -- General version: parametrized by how you make new names
470
471 rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]
472 rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
473 -- Despite the map, the monad ensures that each pattern binds
474 -- variables that may be mentioned in subsequent patterns in the list
475
476 --------------------
477 -- The workhorse
478 rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
479 rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
480
481 rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
482 rnPatAndThen _ (WildPat _) = return (WildPat noExtField)
483 rnPatAndThen mk (ParPat x lpar pat rpar) =
484 do { pat' <- rnLPatAndThen mk pat
485 ; return (ParPat x lpar pat' rpar) }
486 rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat
487 ; return (LazyPat noExtField pat') }
488 rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat
489 ; return (BangPat noExtField pat') }
490 rnPatAndThen mk (VarPat x (L l rdr))
491 = do { loc <- liftCps getSrcSpanM
492 ; name <- newPatName mk (L (noAnnSrcSpan loc) rdr)
493 ; return (VarPat x (L l name)) }
494 -- we need to bind pattern variables for view pattern expressions
495 -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
496
497 rnPatAndThen mk (SigPat _ pat sig)
498 -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
499 -- important to rename its type signature _before_ renaming the rest of the
500 -- pattern, so that type variables are first bound by the _outermost_ pattern
501 -- type signature they occur in. This keeps the type checker happy when
502 -- pattern type signatures happen to be nested (#7827)
503 --
504 -- f ((Just (x :: a) :: Maybe a)
505 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here
506 -- ~~~~~~~~~~~~~~~^ the same `a' then used here
507 = do { sig' <- rnHsPatSigTypeAndThen sig
508 ; pat' <- rnLPatAndThen mk pat
509 ; return (SigPat noExtField pat' sig' ) }
510 where
511 rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn)
512 rnHsPatSigTypeAndThen sig = liftCpsWithCont (rnHsPatSigType AlwaysBind PatCtx sig)
513
514 rnPatAndThen mk (LitPat x lit)
515 | HsString src s <- lit
516 = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
517 ; if ovlStr
518 then rnPatAndThen mk
519 (mkNPat (noLocA (mkHsIsString src s))
520 Nothing noAnn)
521 else normal_lit }
522 | otherwise = normal_lit
523 where
524 normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
525
526 rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
527 = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
528 ; mb_neg' -- See Note [Negative zero]
529 <- let negative = do { (neg, fvs) <- lookupSyntax negateName
530 ; return (Just neg, fvs) }
531 positive = return (Nothing, emptyFVs)
532 in liftCpsFV $ case (mb_neg , mb_neg') of
533 (Nothing, Just _ ) -> negative
534 (Just _ , Nothing) -> negative
535 (Nothing, Nothing) -> positive
536 (Just _ , Just _ ) -> positive
537 ; eq' <- liftCpsFV $ lookupSyntax eqName
538 ; return (NPat x (L l lit') mb_neg' eq') }
539
540 rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ )
541 = do { new_name <- newPatName mk (l2n rdr)
542 ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
543 -- We skip negateName as
544 -- negative zero doesn't make
545 -- sense in n + k patterns
546 ; minus <- liftCpsFV $ lookupSyntax minusName
547 ; ge <- liftCpsFV $ lookupSyntax geName
548 ; return (NPlusKPat noExtField (L (noAnnSrcSpan $ nameSrcSpan new_name) new_name)
549 (L l lit') lit' ge minus) }
550 -- The Report says that n+k patterns must be in Integral
551
552 rnPatAndThen mk (AsPat _ rdr pat)
553 = do { new_name <- newPatLName mk rdr
554 ; pat' <- rnLPatAndThen mk pat
555 ; return (AsPat noExtField new_name pat') }
556
557 rnPatAndThen mk p@(ViewPat _ expr pat)
558 = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
559 ; checkErr vp_flag (TcRnIllegalViewPattern p) }
560 -- Because of the way we're arranging the recursive calls,
561 -- this will be in the right context
562 ; expr' <- liftCpsFV $ rnLExpr expr
563 ; pat' <- rnLPatAndThen mk pat
564 -- Note: at this point the PreTcType in ty can only be a placeHolder
565 -- ; return (ViewPat expr' pat' ty) }
566
567 -- Note: we can't cook up an inverse for an arbitrary view pattern,
568 -- so we pass 'Nothing'.
569 ; return (ViewPat Nothing expr' pat') }
570
571 rnPatAndThen mk (ConPat _ con args)
572 -- rnConPatAndThen takes care of reconstructing the pattern
573 -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
574 = case unLoc con == nameRdrName (dataConName nilDataCon) of
575 True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
576 ; if ol_flag then rnPatAndThen mk (ListPat noAnn [])
577 else rnConPatAndThen mk con args}
578 False -> rnConPatAndThen mk con args
579
580 rnPatAndThen mk (ListPat _ pats)
581 = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
582 ; pats' <- rnLPatsAndThen mk pats
583 ; if not opt_OverloadedLists
584 then return (ListPat noExtField pats')
585 else
586 -- If OverloadedLists is enabled, desugar to a view pattern.
587 -- See Note [Desugaring overloaded list patterns]
588 do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
589 -- Use 'fromList' as proof of invertibility of the view pattern.
590 -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn
591 ; (from_list_n_name,_) <- liftCps $ lookupSyntaxName fromListNName
592 ; let
593 lit_n = mkIntegralLit (length pats)
594 hs_lit = genHsIntegralLit lit_n
595 inverse = genHsApps from_list_n_name [hs_lit]
596 rn_list_pat = ListPat noExtField pats'
597 exp_expr = genLHsVar to_list_name
598 exp_list_pat = ViewPat (Just inverse) exp_expr (wrapGenSpan rn_list_pat)
599 ; return $ mkExpandedPat rn_list_pat exp_list_pat }}
600
601 rnPatAndThen mk (TuplePat _ pats boxed)
602 = do { pats' <- rnLPatsAndThen mk pats
603 ; return (TuplePat noExtField pats' boxed) }
604
605 rnPatAndThen mk (SumPat _ pat alt arity)
606 = do { pat <- rnLPatAndThen mk pat
607 ; return (SumPat noExtField pat alt arity)
608 }
609
610 -- If a splice has been run already, just rename the result.
611 rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))
612 = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat
613
614 rnPatAndThen mk (SplicePat _ splice)
615 = do { eith <- liftCpsFV $ rnSplicePat splice
616 ; case eith of -- See Note [rnSplicePat] in GHC.Rename.Splice
617 Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed
618 Right already_renamed -> return already_renamed }
619
620 --------------------
621 rnConPatAndThen :: NameMaker
622 -> LocatedN RdrName -- the constructor
623 -> HsConPatDetails GhcPs
624 -> CpsRn (Pat GhcRn)
625
626 rnConPatAndThen mk con (PrefixCon tyargs pats)
627 = do { con' <- lookupConCps con
628 ; liftCps check_lang_exts
629 ; tyargs' <- forM tyargs $ \t ->
630 liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t
631 ; pats' <- rnLPatsAndThen mk pats
632 ; return $ ConPat
633 { pat_con_ext = noExtField
634 , pat_con = con'
635 , pat_args = PrefixCon tyargs' pats'
636 }
637 }
638 where
639 check_lang_exts :: RnM ()
640 check_lang_exts = do
641 scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
642 type_app <- xoptM LangExt.TypeApplications
643 unless (scoped_tyvars && type_app) $
644 case listToMaybe tyargs of
645 Nothing -> pure ()
646 Just tyarg -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $
647 hang (text "Illegal visible type application in a pattern:"
648 <+> quotes (char '@' <> ppr tyarg))
649 2 (text "Both ScopedTypeVariables and TypeApplications are"
650 <+> text "required to use this feature")
651
652 rnConPatAndThen mk con (InfixCon pat1 pat2)
653 = do { con' <- lookupConCps con
654 ; pat1' <- rnLPatAndThen mk pat1
655 ; pat2' <- rnLPatAndThen mk pat2
656 ; fixity <- liftCps $ lookupFixityRn (unLoc con')
657 ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
658
659 rnConPatAndThen mk con (RecCon rpats)
660 = do { con' <- lookupConCps con
661 ; rpats' <- rnHsRecPatsAndThen mk con' rpats
662 ; return $ ConPat
663 { pat_con_ext = noExtField
664 , pat_con = con'
665 , pat_args = RecCon rpats'
666 }
667 }
668
669 checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
670 checkUnusedRecordWildcardCps loc dotdot_names =
671 CpsRn (\thing -> do
672 (r, fvs) <- thing ()
673 checkUnusedRecordWildcard loc fvs dotdot_names
674 return (r, fvs) )
675 --------------------
676 rnHsRecPatsAndThen :: NameMaker
677 -> LocatedN Name -- Constructor
678 -> HsRecFields GhcPs (LPat GhcPs)
679 -> CpsRn (HsRecFields GhcRn (LPat GhcRn))
680 rnHsRecPatsAndThen mk (L _ con)
681 hs_rec_fields@(HsRecFields { rec_dotdot = dd })
682 = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
683 hs_rec_fields
684 ; flds' <- mapM rn_field (flds `zip` [1..])
685 ; check_unused_wildcard (implicit_binders flds' <$> dd)
686 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
687 where
688 mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n)
689 rn_field (L l fld, n') =
690 do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hfbRHS fld)
691 ; return (L l (fld { hfbRHS = arg' })) }
692
693 loc = maybe noSrcSpan getLoc dd
694
695 -- Get the arguments of the implicit binders
696 implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats
697 where
698 implicit_pats = map (hfbRHS . unLoc) (drop n fs)
699
700 -- Don't warn for let P{..} = ... in ...
701 check_unused_wildcard = case mk of
702 LetMk{} -> const (return ())
703 LamMk{} -> checkUnusedRecordWildcardCps loc
704
705 -- Suppress unused-match reporting for fields introduced by ".."
706 nested_mk Nothing mk _ = mk
707 nested_mk (Just _) mk@(LetMk {}) _ = mk
708 nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'
709 = LamMk (report_unused && (n' <= n))
710
711
712 {- *********************************************************************
713 * *
714 Generating code for HsPatExpanded
715 See Note [Handling overloaded and rebindable constructs]
716 * *
717 ********************************************************************* -}
718
719 -- | Build a 'HsPatExpansion' out of an extension constructor,
720 -- and the two components of the expansion: original and
721 -- desugared patterns
722 mkExpandedPat
723 :: Pat GhcRn -- ^ source pattern
724 -> Pat GhcRn -- ^ expanded pattern
725 -> Pat GhcRn -- ^ suitably wrapped 'HsPatExpansion'
726 mkExpandedPat a b = XPat (HsPatExpanded a b)
727
728 {-
729 ************************************************************************
730 * *
731 Record fields
732 * *
733 ************************************************************************
734 -}
735
736 data HsRecFieldContext
737 = HsRecFieldCon Name
738 | HsRecFieldPat Name
739 | HsRecFieldUpd
740
741 rnHsRecFields
742 :: forall arg.
743 HsRecFieldContext
744 -> (SrcSpan -> RdrName -> arg)
745 -- When punning, use this to build a new field
746 -> HsRecFields GhcPs (LocatedA arg)
747 -> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars)
748
749 -- This surprisingly complicated pass
750 -- a) looks up the field name (possibly using disambiguation)
751 -- b) fills in puns and dot-dot stuff
752 -- When we've finished, we've renamed the LHS, but not the RHS,
753 -- of each x=e binding
754 --
755 -- This is used for record construction and pattern-matching, but not updates.
756
757 rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
758 = do { pun_ok <- xoptM LangExt.NamedFieldPuns
759 ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
760 ; let parent = guard disambig_ok >> mb_con
761 ; flds1 <- mapM (rn_fld pun_ok parent) flds
762 ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
763 ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
764 ; let all_flds | null dotdot_flds = flds1
765 | otherwise = flds1 ++ dotdot_flds
766 ; return (all_flds, mkFVs (getFieldIds all_flds)) }
767 where
768 mb_con = case ctxt of
769 HsRecFieldCon con -> Just con
770 HsRecFieldPat con -> Just con
771 _ {- update -} -> Nothing
772
773 rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg)
774 -> RnM (LHsRecField GhcRn (LocatedA arg))
775 rn_fld pun_ok parent (L l
776 (HsFieldBind
777 { hfbLHS =
778 (L loc (FieldOcc _ (L ll lbl)))
779 , hfbRHS = arg
780 , hfbPun = pun }))
781 = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl
782 ; arg' <- if pun
783 then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))
784 -- Discard any module qualifier (#11662)
785 ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
786 ; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) }
787 else return arg
788 ; return (L l (HsFieldBind
789 { hfbAnn = noAnn
790 , hfbLHS = (L loc (FieldOcc sel (L ll lbl)))
791 , hfbRHS = arg'
792 , hfbPun = pun })) }
793
794
795 rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat
796 -> Maybe Name -- The constructor (Nothing for an
797 -- out of scope constructor)
798 -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields
799 -> RnM ([LHsRecField GhcRn (LocatedA arg)]) -- Field Labels we need to fill in
800 rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match
801 | not (isUnboundName con) -- This test is because if the constructor
802 -- isn't in scope the constructor lookup will add
803 -- an error but still return an unbound name. We
804 -- don't want that to screw up the dot-dot fill-in stuff.
805 = assert (flds `lengthIs` n) $
806 do { dd_flag <- xoptM LangExt.RecordWildCards
807 ; checkErr dd_flag (needFlagDotDot ctxt)
808 ; (rdr_env, lcl_env) <- getRdrEnvs
809 ; con_fields <- lookupConstructorFields con
810 ; when (null con_fields) (addErr (TcRnIllegalWildcardsInConstructor con))
811 ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
812
813 -- For constructor uses (but not patterns)
814 -- the arg should be in scope locally;
815 -- i.e. not top level or imported
816 -- Eg. data R = R { x,y :: Int }
817 -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y}
818 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env
819
820 (dot_dot_fields, dot_dot_gres)
821 = unzip [ (fl, gre)
822 | fl <- con_fields
823 , let lbl = mkVarOccFS (flLabel fl)
824 , not (lbl `elemOccSet` present_flds)
825 , Just gre <- [lookupGRE_FieldLabel rdr_env fl]
826 -- Check selector is in scope
827 , case ctxt of
828 HsRecFieldCon {} -> arg_in_scope lbl
829 _other -> True ]
830
831 ; addUsedGREs dot_dot_gres
832 ; let locn = noAnnSrcSpan loc
833 ; return [ L (noAnnSrcSpan loc) (HsFieldBind
834 { hfbAnn = noAnn
835 , hfbLHS
836 = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))
837 , hfbRHS = L locn (mk_arg loc arg_rdr)
838 , hfbPun = False })
839 | fl <- dot_dot_fields
840 , let sel = flSelector fl
841 , let arg_rdr = mkVarUnqual (flLabel fl) ] }
842
843 rn_dotdot _dotdot _mb_con _flds
844 = return []
845 -- _dotdot = Nothing => No ".." at all
846 -- _mb_con = Nothing => Record update
847 -- _mb_con = Just unbound => Out of scope data constructor
848
849 dup_flds :: [NE.NonEmpty RdrName]
850 -- Each list represents a RdrName that occurred more than once
851 -- (the list contains all occurrences)
852 -- Each list in dup_fields is non-empty
853 (_, dup_flds) = removeDups compare (getFieldLbls flds)
854
855
856 -- NB: Consider this:
857 -- module Foo where { data R = R { fld :: Int } }
858 -- module Odd where { import Foo; fld x = x { fld = 3 } }
859 -- Arguably this should work, because the reference to 'fld' is
860 -- unambiguous because there is only one field id 'fld' in scope.
861 -- But currently it's rejected.
862
863 rnHsRecUpdFields
864 :: [LHsRecUpdField GhcPs]
865 -> RnM ([LHsRecUpdField GhcRn], FreeVars)
866 rnHsRecUpdFields flds
867 = do { pun_ok <- xoptM LangExt.NamedFieldPuns
868 ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags
869 ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds
870 ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
871
872 -- Check for an empty record update e {}
873 -- NB: don't complain about e { .. }, because rn_dotdot has done that already
874 ; when (null flds) $ addErr TcRnEmptyRecordUpdate
875
876 ; return (flds1, plusFVs fvss) }
877 where
878 rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs
879 -> RnM (LHsRecUpdField GhcRn, FreeVars)
880 rn_fld pun_ok dup_fields_ok (L l (HsFieldBind { hfbLHS = L loc f
881 , hfbRHS = arg
882 , hfbPun = pun }))
883 = do { let lbl = rdrNameAmbiguousFieldOcc f
884 ; mb_sel <- setSrcSpanA loc $
885 -- Defer renaming of overloaded fields to the typechecker
886 -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
887 lookupRecFieldOcc_update dup_fields_ok lbl
888 ; arg' <- if pun
889 then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))
890 -- Discard any module qualifier (#11662)
891 ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
892 ; return (L (l2l loc) (HsVar noExtField
893 (L (l2l loc) arg_rdr))) }
894 else return arg
895 ; (arg'', fvs) <- rnLExpr arg'
896
897 ; let (lbl', fvs') = case mb_sel of
898 UnambiguousGre gname -> let sel_name = greNameMangledName gname
899 in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name)
900 AmbiguousFields -> (Ambiguous noExtField (L (l2l loc) lbl), fvs)
901
902 ; return (L l (HsFieldBind { hfbAnn = noAnn
903 , hfbLHS = L loc lbl'
904 , hfbRHS = arg''
905 , hfbPun = pun }), fvs') }
906
907 dup_flds :: [NE.NonEmpty RdrName]
908 -- Each list represents a RdrName that occurred more than once
909 -- (the list contains all occurrences)
910 -- Each list in dup_fields is non-empty
911 (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
912
913
914
915 getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
916 getFieldIds flds = map (hsRecFieldSel . unLoc) flds
917
918 getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName]
919 getFieldLbls flds
920 = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds
921
922 getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
923 getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds
924
925 needFlagDotDot :: HsRecFieldContext -> TcRnMessage
926 needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart
927
928 dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage
929 dupFieldErr ctxt = TcRnDuplicateFieldName (toRecordFieldPart ctxt)
930
931 toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart
932 toRecordFieldPart (HsRecFieldCon n) = RecordFieldConstructor n
933 toRecordFieldPart (HsRecFieldPat n) = RecordFieldPattern n
934 toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate
935
936 {-
937 ************************************************************************
938 * *
939 \subsubsection{Literals}
940 * *
941 ************************************************************************
942
943 When literals occur we have to make sure
944 that the types and classes they involve
945 are made available.
946 -}
947
948 rnLit :: HsLit p -> RnM ()
949 rnLit (HsChar _ c) = checkErr (inCharRange c) (TcRnCharLiteralOutOfRange c)
950 rnLit _ = return ()
951
952 -- | Turn a Fractional-looking literal which happens to be an integer into an
953 -- Integer-looking literal.
954 -- We only convert numbers where the exponent is between 0 and 100 to avoid
955 -- converting huge numbers and incurring long compilation times. See #15646.
956 generalizeOverLitVal :: OverLitVal -> OverLitVal
957 generalizeOverLitVal (HsFractional fl@(FL {fl_text=src,fl_neg=neg,fl_exp=e}))
958 | e >= -100 && e <= 100
959 , let val = rationalFromFractionalLit fl
960 , denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val})
961 generalizeOverLitVal lit = lit
962
963 isNegativeZeroOverLit :: HsOverLit t -> Bool
964 isNegativeZeroOverLit lit
965 = case ol_val lit of
966 HsIntegral i -> 0 == il_value i && il_neg i
967 -- For HsFractional, the value of fl is n * (b ^^ e) so it is sufficient
968 -- to check if n = 0. b is equal to either 2 or 10. We don't call
969 -- rationalFromFractionalLit here as it is expensive when e is big.
970 HsFractional fl -> 0 == fl_signi fl && fl_neg fl
971 _ -> False
972
973 {-
974 Note [Negative zero]
975 ~~~~~~~~~~~~~~~~~~~~~~~~~
976 There were problems with negative zero in conjunction with Negative Literals
977 extension. Numeric literal value is contained in Integer and Rational types
978 inside IntegralLit and FractionalLit. These types cannot represent negative
979 zero value. So we had to add explicit field 'neg' which would hold information
980 about literal sign. Here in rnOverLit we use it to detect negative zeroes and
981 in this case return not only literal itself but also negateName so that users
982 can apply it explicitly. In this case it stays negative zero. #13211
983 -}
984
985 rnOverLit :: HsOverLit t ->
986 RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
987 rnOverLit origLit
988 = do { opt_NumDecimals <- xoptM LangExt.NumDecimals
989 ; let { lit@(OverLit {ol_val=val})
990 | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}
991 | otherwise = origLit
992 }
993 ; let std_name = hsOverLitName val
994 ; (from_thing_name, fvs1) <- lookupSyntaxName std_name
995 ; let rebindable = from_thing_name /= std_name
996 lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable
997 , ol_from_fun = noLocA from_thing_name } }
998 ; if isNegativeZeroOverLit lit'
999 then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName
1000 ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
1001 , fvs1 `plusFV` fvs2) }
1002 else return ((lit', Nothing), fvs1) }