3d5f3b92b740bb2e3a893b7b73ca291524800ebd
[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 #-}
14 {-# LANGUAGE FlexibleContexts #-}
15 {-# LANGUAGE TypeFamilies #-}
16 {-# LANGUAGE RankNTypes #-}
17 {-# LANGUAGE ScopedTypeVariables #-}
18 {-# LANGUAGE ViewPatterns #-}
19
20 module RnPat (-- main entry points
21 rnPat, rnPats, rnBindPat, rnPatAndThen,
22
23 NameMaker, applyNameMaker, -- a utility for making names:
24 localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names,
25 -- sometimes we want to make top (qualified) names.
26 isTopRecNameMaker,
27
28 rnHsRecFields, HsRecFieldContext(..),
29 rnHsRecUpdFields,
30
31 -- CpsRn monad
32 CpsRn, liftCps,
33
34 -- Literals
35 rnLit, rnOverLit,
36
37 -- Pattern Error messages that are also used elsewhere
38 checkTupSize, patSigErr
39 ) where
40
41 -- ENH: thin imports to only what is necessary for patterns
42
43 import GhcPrelude
44
45 import {-# SOURCE #-} RnExpr ( rnLExpr )
46 import {-# SOURCE #-} RnSplice ( rnSplicePat )
47
48 #include "HsVersions.h"
49
50 import HsSyn
51 import TcRnMonad
52 import TcHsSyn ( hsOverLitName )
53 import RnEnv
54 import RnFixity
55 import RnUtils ( HsDocContext(..), newLocalBndrRn, bindLocalNames
56 , warnUnusedMatches, newLocalBndrRn
57 , checkUnusedRecordWildcard
58 , checkDupNames, checkDupAndShadowedNames
59 , checkTupSize , unknownSubordinateErr )
60 import RnTypes
61 import PrelNames
62 import Name
63 import NameSet
64 import RdrName
65 import BasicTypes
66 import Util
67 import ListSetOps ( removeDups )
68 import Outputable
69 import SrcLoc
70 import Literal ( inCharRange )
71 import TysWiredIn ( nilDataCon )
72 import DataCon
73 import qualified GHC.LanguageExtensions as LangExt
74
75 import Control.Monad ( when, liftM, ap, guard )
76 import qualified Data.List.NonEmpty as NE
77 import Data.Ratio
78
79 {-
80 *********************************************************
81 * *
82 The CpsRn Monad
83 * *
84 *********************************************************
85
86 Note [CpsRn monad]
87 ~~~~~~~~~~~~~~~~~~
88 The CpsRn monad uses continuation-passing style to support this
89 style of programming:
90
91 do { ...
92 ; ns <- bindNames rs
93 ; ...blah... }
94
95 where rs::[RdrName], ns::[Name]
96
97 The idea is that '...blah...'
98 a) sees the bindings of ns
99 b) returns the free variables it mentions
100 so that bindNames can report unused ones
101
102 In particular,
103 mapM rnPatAndThen [p1, p2, p3]
104 has a *left-to-right* scoping: it makes the binders in
105 p1 scope over p2,p3.
106 -}
107
108 newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
109 -> RnM (r, FreeVars) }
110 -- See Note [CpsRn monad]
111
112 instance Functor CpsRn where
113 fmap = liftM
114
115 instance Applicative CpsRn where
116 pure x = CpsRn (\k -> k x)
117 (<*>) = ap
118
119 instance Monad CpsRn where
120 (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
121
122 runCps :: CpsRn a -> RnM (a, FreeVars)
123 runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
124
125 liftCps :: RnM a -> CpsRn a
126 liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
127
128 liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
129 liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
130 ; (r,fvs2) <- k v
131 ; return (r, fvs1 `plusFV` fvs2) })
132
133 wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) =>
134 (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b
135 -- Set the location, and also wrap it around the value returned
136 wrapSrcSpanCps fn (dL->L loc a)
137 = CpsRn (\k -> setSrcSpan loc $
138 unCpsRn (fn a) $ \v ->
139 k (cL loc v))
140
141 lookupConCps :: Located RdrName -> CpsRn (Located Name)
142 lookupConCps con_rdr
143 = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr
144 ; (r, fvs) <- k con_name
145 ; return (r, addOneFV fvs (unLoc con_name)) })
146 -- We add the constructor name to the free vars
147 -- See Note [Patterns are uses]
148
149 {-
150 Note [Patterns are uses]
151 ~~~~~~~~~~~~~~~~~~~~~~~~
152 Consider
153 module Foo( f, g ) where
154 data T = T1 | T2
155
156 f T1 = True
157 f T2 = False
158
159 g _ = T1
160
161 Arguably we should report T2 as unused, even though it appears in a
162 pattern, because it never occurs in a constructed position. See
163 Trac #7336.
164 However, implementing this in the face of pattern synonyms would be
165 less straightforward, since given two pattern synonyms
166
167 pattern P1 <- P2
168 pattern P2 <- ()
169
170 we need to observe the dependency between P1 and P2 so that type
171 checking can be done in the correct order (just like for value
172 bindings). Dependencies between bindings is analyzed in the renamer,
173 where we don't know yet whether P2 is a constructor or a pattern
174 synonym. So for now, we do report conid occurrences in patterns as
175 uses.
176
177 *********************************************************
178 * *
179 Name makers
180 * *
181 *********************************************************
182
183 Externally abstract type of name makers,
184 which is how you go from a RdrName to a Name
185 -}
186
187 data NameMaker
188 = LamMk -- Lambdas
189 Bool -- True <=> report unused bindings
190 -- (even if True, the warning only comes out
191 -- if -Wunused-matches is on)
192
193 | LetMk -- Let bindings, incl top level
194 -- Do *not* check for unused bindings
195 TopLevelFlag
196 MiniFixityEnv
197
198 topRecNameMaker :: MiniFixityEnv -> NameMaker
199 topRecNameMaker fix_env = LetMk TopLevel fix_env
200
201 isTopRecNameMaker :: NameMaker -> Bool
202 isTopRecNameMaker (LetMk TopLevel _) = True
203 isTopRecNameMaker _ = False
204
205 localRecNameMaker :: MiniFixityEnv -> NameMaker
206 localRecNameMaker fix_env = LetMk NotTopLevel fix_env
207
208 matchNameMaker :: HsMatchContext a -> NameMaker
209 matchNameMaker ctxt = LamMk report_unused
210 where
211 -- Do not report unused names in interactive contexts
212 -- i.e. when you type 'x <- e' at the GHCi prompt
213 report_unused = case ctxt of
214 StmtCtxt GhciStmtCtxt -> False
215 -- also, don't warn in pattern quotes, as there
216 -- is no RHS where the variables can be used!
217 ThPatQuote -> False
218 _ -> True
219
220 rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)
221 rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)
222
223 newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
224 newPatLName name_maker rdr_name@(dL->L loc _)
225 = do { name <- newPatName name_maker rdr_name
226 ; return (cL loc name) }
227
228 newPatName :: NameMaker -> Located RdrName -> CpsRn Name
229 newPatName (LamMk report_unused) rdr_name
230 = CpsRn (\ thing_inside ->
231 do { name <- newLocalBndrRn rdr_name
232 ; (res, fvs) <- bindLocalNames [name] (thing_inside name)
233 ; when report_unused $ warnUnusedMatches [name] fvs
234 ; return (res, name `delFV` fvs) })
235
236 newPatName (LetMk is_top fix_env) rdr_name
237 = CpsRn (\ thing_inside ->
238 do { name <- case is_top of
239 NotTopLevel -> newLocalBndrRn rdr_name
240 TopLevel -> newTopSrcBinder rdr_name
241 ; bindLocalNames [name] $ -- Do *not* use bindLocalNameFV here
242 -- See Note [View pattern usage]
243 addLocalFixities fix_env [name] $
244 thing_inside name })
245
246 -- Note: the bindLocalNames is somewhat suspicious
247 -- because it binds a top-level name as a local name.
248 -- however, this binding seems to work, and it only exists for
249 -- the duration of the patterns and the continuation;
250 -- then the top-level name is added to the global env
251 -- before going on to the RHSes (see RnSource.hs).
252
253 {-
254 Note [View pattern usage]
255 ~~~~~~~~~~~~~~~~~~~~~~~~~
256 Consider
257 let (r, (r -> x)) = x in ...
258 Here the pattern binds 'r', and then uses it *only* in the view pattern.
259 We want to "see" this use, and in let-bindings we collect all uses and
260 report unused variables at the binding level. So we must use bindLocalNames
261 here, *not* bindLocalNameFV. Trac #3943.
262
263
264 Note [Don't report shadowing for pattern synonyms]
265 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
266 There is one special context where a pattern doesn't introduce any new binders -
267 pattern synonym declarations. Therefore we don't check to see if pattern
268 variables shadow existing identifiers as they are never bound to anything
269 and have no scope.
270
271 Without this check, there would be quite a cryptic warning that the `x`
272 in the RHS of the pattern synonym declaration shadowed the top level `x`.
273
274 ```
275 x :: ()
276 x = ()
277
278 pattern P x = Just x
279 ```
280
281 See #12615 for some more examples.
282
283 *********************************************************
284 * *
285 External entry points
286 * *
287 *********************************************************
288
289 There are various entry points to renaming patterns, depending on
290 (1) whether the names created should be top-level names or local names
291 (2) whether the scope of the names is entirely given in a continuation
292 (e.g., in a case or lambda, but not in a let or at the top-level,
293 because of the way mutually recursive bindings are handled)
294 (3) whether the a type signature in the pattern can bind
295 lexically-scoped type variables (for unpacking existential
296 type vars in data constructors)
297 (4) whether we do duplicate and unused variable checking
298 (5) whether there are fixity declarations associated with the names
299 bound by the patterns that need to be brought into scope with them.
300
301 Rather than burdening the clients of this module with all of these choices,
302 we export the three points in this design space that we actually need:
303 -}
304
305 -- ----------- Entry point 1: rnPats -------------------
306 -- Binds local names; the scope of the bindings is entirely in the thing_inside
307 -- * allows type sigs to bind type vars
308 -- * local namemaker
309 -- * unused and duplicate checking
310 -- * no fixities
311 rnPats :: HsMatchContext Name -- for error messages
312 -> [LPat GhcPs]
313 -> ([LPat GhcRn] -> RnM (a, FreeVars))
314 -> RnM (a, FreeVars)
315 rnPats ctxt pats thing_inside
316 = do { envs_before <- getRdrEnvs
317
318 -- (1) rename the patterns, bringing into scope all of the term variables
319 -- (2) then do the thing inside.
320 ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
321 { -- Check for duplicated and shadowed names
322 -- Must do this *after* renaming the patterns
323 -- See Note [Collect binders only after renaming] in HsUtils
324 -- Because we don't bind the vars all at once, we can't
325 -- check incrementally for duplicates;
326 -- Nor can we check incrementally for shadowing, else we'll
327 -- complain *twice* about duplicates e.g. f (x,x) = ...
328 --
329 -- See note [Don't report shadowing for pattern synonyms]
330 ; let bndrs = collectPatsBinders pats'
331 ; addErrCtxt doc_pat $
332 if isPatSynCtxt ctxt
333 then checkDupNames bndrs
334 else checkDupAndShadowedNames envs_before bndrs
335 ; thing_inside pats' } }
336 where
337 doc_pat = text "In" <+> pprMatchContext ctxt
338
339 rnPat :: HsMatchContext Name -- for error messages
340 -> LPat GhcPs
341 -> (LPat GhcRn -> RnM (a, FreeVars))
342 -> RnM (a, FreeVars) -- Variables bound by pattern do not
343 -- appear in the result FreeVars
344 rnPat ctxt pat thing_inside
345 = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
346
347 applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)
348 applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)
349 ; return n }
350
351 -- ----------- Entry point 2: rnBindPat -------------------
352 -- Binds local names; in a recursive scope that involves other bound vars
353 -- e.g let { (x, Just y) = e1; ... } in ...
354 -- * does NOT allows type sig to bind type vars
355 -- * local namemaker
356 -- * no unused and duplicate checking
357 -- * fixities might be coming in
358 rnBindPat :: NameMaker
359 -> LPat GhcPs
360 -> RnM (LPat GhcRn, FreeVars)
361 -- Returned FreeVars are the free variables of the pattern,
362 -- of course excluding variables bound by this pattern
363
364 rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
365
366 {-
367 *********************************************************
368 * *
369 The main event
370 * *
371 *********************************************************
372 -}
373
374 -- ----------- Entry point 3: rnLPatAndThen -------------------
375 -- General version: parametrized by how you make new names
376
377 rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]
378 rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
379 -- Despite the map, the monad ensures that each pattern binds
380 -- variables that may be mentioned in subsequent patterns in the list
381
382 --------------------
383 -- The workhorse
384 rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
385 rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
386
387 rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
388 rnPatAndThen _ (WildPat _) = return (WildPat noExt)
389 rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat
390 ; return (ParPat x pat') }
391 rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat
392 ; return (LazyPat x pat') }
393 rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat
394 ; return (BangPat x pat') }
395 rnPatAndThen mk (VarPat x (dL->L l rdr))
396 = do { loc <- liftCps getSrcSpanM
397 ; name <- newPatName mk (cL loc rdr)
398 ; return (VarPat x (cL l name)) }
399 -- we need to bind pattern variables for view pattern expressions
400 -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
401
402 rnPatAndThen mk (SigPat x pat sig)
403 -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
404 -- important to rename its type signature _before_ renaming the rest of the
405 -- pattern, so that type variables are first bound by the _outermost_ pattern
406 -- type signature they occur in. This keeps the type checker happy when
407 -- pattern type signatures happen to be nested (#7827)
408 --
409 -- f ((Just (x :: a) :: Maybe a)
410 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here
411 -- ~~~~~~~~~~~~~~~^ the same `a' then used here
412 = do { sig' <- rnHsSigCps sig
413 ; pat' <- rnLPatAndThen mk pat
414 ; return (SigPat x pat' sig' ) }
415
416 rnPatAndThen mk (LitPat x lit)
417 | HsString src s <- lit
418 = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
419 ; if ovlStr
420 then rnPatAndThen mk
421 (mkNPat (noLoc (mkHsIsString src s))
422 Nothing)
423 else normal_lit }
424 | otherwise = normal_lit
425 where
426 normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
427
428 rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq)
429 = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
430 ; mb_neg' -- See Note [Negative zero]
431 <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName
432 ; return (Just neg, fvs) }
433 positive = return (Nothing, emptyFVs)
434 in liftCpsFV $ case (mb_neg , mb_neg') of
435 (Nothing, Just _ ) -> negative
436 (Just _ , Nothing) -> negative
437 (Nothing, Nothing) -> positive
438 (Just _ , Just _ ) -> positive
439 ; eq' <- liftCpsFV $ lookupSyntaxName eqName
440 ; return (NPat x (cL l lit') mb_neg' eq') }
441
442 rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ )
443 = do { new_name <- newPatName mk rdr
444 ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
445 -- We skip negateName as
446 -- negative zero doesn't make
447 -- sense in n + k patterns
448 ; minus <- liftCpsFV $ lookupSyntaxName minusName
449 ; ge <- liftCpsFV $ lookupSyntaxName geName
450 ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name)
451 (cL l lit') lit' ge minus) }
452 -- The Report says that n+k patterns must be in Integral
453
454 rnPatAndThen mk (AsPat x rdr pat)
455 = do { new_name <- newPatLName mk rdr
456 ; pat' <- rnLPatAndThen mk pat
457 ; return (AsPat x new_name pat') }
458
459 rnPatAndThen mk p@(ViewPat x expr pat)
460 = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
461 ; checkErr vp_flag (badViewPat p) }
462 -- Because of the way we're arranging the recursive calls,
463 -- this will be in the right context
464 ; expr' <- liftCpsFV $ rnLExpr expr
465 ; pat' <- rnLPatAndThen mk pat
466 -- Note: at this point the PreTcType in ty can only be a placeHolder
467 -- ; return (ViewPat expr' pat' ty) }
468 ; return (ViewPat x expr' pat') }
469
470 rnPatAndThen mk (ConPatIn con stuff)
471 -- rnConPatAndThen takes care of reconstructing the pattern
472 -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
473 = case unLoc con == nameRdrName (dataConName nilDataCon) of
474 True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
475 ; if ol_flag then rnPatAndThen mk (ListPat noExt [])
476 else rnConPatAndThen mk con stuff}
477 False -> rnConPatAndThen mk con stuff
478
479 rnPatAndThen mk (ListPat _ pats)
480 = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
481 ; pats' <- rnLPatsAndThen mk pats
482 ; case opt_OverloadedLists of
483 True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
484 ; return (ListPat (Just to_list_name) pats')}
485 False -> return (ListPat Nothing pats') }
486
487 rnPatAndThen mk (TuplePat x pats boxed)
488 = do { liftCps $ checkTupSize (length pats)
489 ; pats' <- rnLPatsAndThen mk pats
490 ; return (TuplePat x pats' boxed) }
491
492 rnPatAndThen mk (SumPat x pat alt arity)
493 = do { pat <- rnLPatAndThen mk pat
494 ; return (SumPat x pat alt arity)
495 }
496
497 -- If a splice has been run already, just rename the result.
498 rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))
499 = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat
500
501 rnPatAndThen mk (SplicePat _ splice)
502 = do { eith <- liftCpsFV $ rnSplicePat splice
503 ; case eith of -- See Note [rnSplicePat] in RnSplice
504 Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed
505 Right already_renamed -> return already_renamed }
506
507 rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
508
509
510 --------------------
511 rnConPatAndThen :: NameMaker
512 -> Located RdrName -- the constructor
513 -> HsConPatDetails GhcPs
514 -> CpsRn (Pat GhcRn)
515
516 rnConPatAndThen mk con (PrefixCon pats)
517 = do { con' <- lookupConCps con
518 ; pats' <- rnLPatsAndThen mk pats
519 ; return (ConPatIn con' (PrefixCon pats')) }
520
521 rnConPatAndThen mk con (InfixCon pat1 pat2)
522 = do { con' <- lookupConCps con
523 ; pat1' <- rnLPatAndThen mk pat1
524 ; pat2' <- rnLPatAndThen mk pat2
525 ; fixity <- liftCps $ lookupFixityRn (unLoc con')
526 ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
527
528 rnConPatAndThen mk con (RecCon rpats)
529 = do { con' <- lookupConCps con
530 ; rpats' <- rnHsRecPatsAndThen mk con' rpats
531 ; return (ConPatIn con' (RecCon rpats')) }
532
533 checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
534 checkUnusedRecordWildcardCps loc dotdot_names =
535 CpsRn (\thing -> do
536 (r, fvs) <- thing ()
537 checkUnusedRecordWildcard loc fvs dotdot_names
538 return (r, fvs) )
539 --------------------
540 rnHsRecPatsAndThen :: NameMaker
541 -> Located Name -- Constructor
542 -> HsRecFields GhcPs (LPat GhcPs)
543 -> CpsRn (HsRecFields GhcRn (LPat GhcRn))
544 rnHsRecPatsAndThen mk (dL->L _ con)
545 hs_rec_fields@(HsRecFields { rec_dotdot = dd })
546 = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
547 hs_rec_fields
548 ; flds' <- mapM rn_field (flds `zip` [1..])
549 ; check_unused_wildcard (implicit_binders flds' <$> dd)
550 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
551 where
552 mkVarPat l n = VarPat noExt (cL l n)
553 rn_field (dL->L l fld, n') =
554 do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)
555 ; return (cL l (fld { hsRecFieldArg = arg' })) }
556
557 loc = maybe noSrcSpan getLoc dd
558
559 -- Get the arguments of the implicit binders
560 implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats
561 where
562 implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs)
563
564 -- Don't warn for let P{..} = ... in ...
565 check_unused_wildcard = case mk of
566 LetMk{} -> const (return ())
567 LamMk{} -> checkUnusedRecordWildcardCps loc
568
569 -- Suppress unused-match reporting for fields introduced by ".."
570 nested_mk Nothing mk _ = mk
571 nested_mk (Just _) mk@(LetMk {}) _ = mk
572 nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'
573 = LamMk (report_unused && (n' <= n))
574
575 {-
576 ************************************************************************
577 * *
578 Record fields
579 * *
580 ************************************************************************
581 -}
582
583 data HsRecFieldContext
584 = HsRecFieldCon Name
585 | HsRecFieldPat Name
586 | HsRecFieldUpd
587
588 rnHsRecFields
589 :: forall arg. HasSrcSpan arg =>
590 HsRecFieldContext
591 -> (SrcSpan -> RdrName -> SrcSpanLess arg)
592 -- When punning, use this to build a new field
593 -> HsRecFields GhcPs arg
594 -> RnM ([LHsRecField GhcRn arg], FreeVars)
595
596 -- This surprisingly complicated pass
597 -- a) looks up the field name (possibly using disambiguation)
598 -- b) fills in puns and dot-dot stuff
599 -- When we've finished, we've renamed the LHS, but not the RHS,
600 -- of each x=e binding
601 --
602 -- This is used for record construction and pattern-matching, but not updates.
603
604 rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
605 = do { pun_ok <- xoptM LangExt.RecordPuns
606 ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
607 ; let parent = guard disambig_ok >> mb_con
608 ; flds1 <- mapM (rn_fld pun_ok parent) flds
609 ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
610 ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
611 ; let all_flds | null dotdot_flds = flds1
612 | otherwise = flds1 ++ dotdot_flds
613 ; return (all_flds, mkFVs (getFieldIds all_flds)) }
614 where
615 mb_con = case ctxt of
616 HsRecFieldCon con -> Just con
617 HsRecFieldPat con -> Just con
618 _ {- update -} -> Nothing
619
620 rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg
621 -> RnM (LHsRecField GhcRn arg)
622 rn_fld pun_ok parent (dL->L l
623 (HsRecField
624 { hsRecFieldLbl =
625 (dL->L loc (FieldOcc _ (dL->L ll lbl)))
626 , hsRecFieldArg = arg
627 , hsRecPun = pun }))
628 = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
629 ; arg' <- if pun
630 then do { checkErr pun_ok (badPun (cL loc lbl))
631 -- Discard any module qualifier (#11662)
632 ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
633 ; return (cL loc (mk_arg loc arg_rdr)) }
634 else return arg
635 ; return (cL l (HsRecField
636 { hsRecFieldLbl = (cL loc (FieldOcc
637 sel (cL ll lbl)))
638 , hsRecFieldArg = arg'
639 , hsRecPun = pun })) }
640 rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _))
641 = panic "rnHsRecFields"
642 rn_fld _ _ _ = panic "rn_fld: Impossible Match"
643 -- due to #15884
644
645
646 rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in HsPat
647 -> Maybe Name -- The constructor (Nothing for an
648 -- out of scope constructor)
649 -> [LHsRecField GhcRn arg] -- Explicit fields
650 -> RnM ([LHsRecField GhcRn arg]) -- Field Labels we need to fill in
651 rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match
652 | not (isUnboundName con) -- This test is because if the constructor
653 -- isn't in scope the constructor lookup will add
654 -- an error but still return an unbound name. We
655 -- don't want that to screw up the dot-dot fill-in stuff.
656 = ASSERT( flds `lengthIs` n )
657 do { dd_flag <- xoptM LangExt.RecordWildCards
658 ; checkErr dd_flag (needFlagDotDot ctxt)
659 ; (rdr_env, lcl_env) <- getRdrEnvs
660 ; con_fields <- lookupConstructorFields con
661 ; when (null con_fields) (addErr (badDotDotCon con))
662 ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
663
664 -- For constructor uses (but not patterns)
665 -- the arg should be in scope locally;
666 -- i.e. not top level or imported
667 -- Eg. data R = R { x,y :: Int }
668 -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y}
669 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env
670
671 (dot_dot_fields, dot_dot_gres)
672 = unzip [ (fl, gre)
673 | fl <- con_fields
674 , let lbl = mkVarOccFS (flLabel fl)
675 , not (lbl `elemOccSet` present_flds)
676 , Just gre <- [lookupGRE_FieldLabel rdr_env fl]
677 -- Check selector is in scope
678 , case ctxt of
679 HsRecFieldCon {} -> arg_in_scope lbl
680 _other -> True ]
681
682 ; addUsedGREs dot_dot_gres
683 ; return [ cL loc (HsRecField
684 { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr))
685 , hsRecFieldArg = cL loc (mk_arg loc arg_rdr)
686 , hsRecPun = False })
687 | fl <- dot_dot_fields
688 , let sel = flSelector fl
689 , let arg_rdr = mkVarUnqual (flLabel fl) ] }
690
691 rn_dotdot _dotdot _mb_con _flds
692 = return []
693 -- _dotdot = Nothing => No ".." at all
694 -- _mb_con = Nothing => Record update
695 -- _mb_con = Just unbound => Out of scope data constructor
696
697 dup_flds :: [NE.NonEmpty RdrName]
698 -- Each list represents a RdrName that occurred more than once
699 -- (the list contains all occurrences)
700 -- Each list in dup_fields is non-empty
701 (_, dup_flds) = removeDups compare (getFieldLbls flds)
702
703
704 -- NB: Consider this:
705 -- module Foo where { data R = R { fld :: Int } }
706 -- module Odd where { import Foo; fld x = x { fld = 3 } }
707 -- Arguably this should work, because the reference to 'fld' is
708 -- unambiguous because there is only one field id 'fld' in scope.
709 -- But currently it's rejected.
710
711 rnHsRecUpdFields
712 :: [LHsRecUpdField GhcPs]
713 -> RnM ([LHsRecUpdField GhcRn], FreeVars)
714 rnHsRecUpdFields flds
715 = do { pun_ok <- xoptM LangExt.RecordPuns
716 ; overload_ok <- xoptM LangExt.DuplicateRecordFields
717 ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds
718 ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
719
720 -- Check for an empty record update e {}
721 -- NB: don't complain about e { .. }, because rn_dotdot has done that already
722 ; when (null flds) $ addErr emptyUpdateErr
723
724 ; return (flds1, plusFVs fvss) }
725 where
726 doc = text "constructor field name"
727
728 rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs
729 -> RnM (LHsRecUpdField GhcRn, FreeVars)
730 rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f
731 , hsRecFieldArg = arg
732 , hsRecPun = pun }))
733 = do { let lbl = rdrNameAmbiguousFieldOcc f
734 ; sel <- setSrcSpan loc $
735 -- Defer renaming of overloaded fields to the typechecker
736 -- See Note [Disambiguating record fields] in TcExpr
737 if overload_ok
738 then do { mb <- lookupGlobalOccRn_overloaded
739 overload_ok lbl
740 ; case mb of
741 Nothing ->
742 do { addErr
743 (unknownSubordinateErr doc lbl)
744 ; return (Right []) }
745 Just r -> return r }
746 else fmap Left $ lookupGlobalOccRn lbl
747 ; arg' <- if pun
748 then do { checkErr pun_ok (badPun (cL loc lbl))
749 -- Discard any module qualifier (#11662)
750 ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
751 ; return (cL loc (HsVar noExt (cL loc arg_rdr))) }
752 else return arg
753 ; (arg'', fvs) <- rnLExpr arg'
754
755 ; let fvs' = case sel of
756 Left sel_name -> fvs `addOneFV` sel_name
757 Right [sel_name] -> fvs `addOneFV` sel_name
758 Right _ -> fvs
759 lbl' = case sel of
760 Left sel_name ->
761 cL loc (Unambiguous sel_name (cL loc lbl))
762 Right [sel_name] ->
763 cL loc (Unambiguous sel_name (cL loc lbl))
764 Right _ -> cL loc (Ambiguous noExt (cL loc lbl))
765
766 ; return (cL l (HsRecField { hsRecFieldLbl = lbl'
767 , hsRecFieldArg = arg''
768 , hsRecPun = pun }), fvs') }
769
770 dup_flds :: [NE.NonEmpty RdrName]
771 -- Each list represents a RdrName that occurred more than once
772 -- (the list contains all occurrences)
773 -- Each list in dup_fields is non-empty
774 (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
775
776
777
778 getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
779 getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds
780
781 getFieldLbls :: [LHsRecField id arg] -> [RdrName]
782 getFieldLbls flds
783 = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
784
785 getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
786 getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
787
788 needFlagDotDot :: HsRecFieldContext -> SDoc
789 needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,
790 text "Use RecordWildCards to permit this"]
791
792 badDotDotCon :: Name -> SDoc
793 badDotDotCon con
794 = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)
795 , nest 2 (text "The constructor has no labelled fields") ]
796
797 emptyUpdateErr :: SDoc
798 emptyUpdateErr = text "Empty record update"
799
800 badPun :: Located RdrName -> SDoc
801 badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
802 text "Use NamedFieldPuns to permit this"]
803
804 dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc
805 dupFieldErr ctxt dups
806 = hsep [text "duplicate field name",
807 quotes (ppr (NE.head dups)),
808 text "in record", pprRFC ctxt]
809
810 pprRFC :: HsRecFieldContext -> SDoc
811 pprRFC (HsRecFieldCon {}) = text "construction"
812 pprRFC (HsRecFieldPat {}) = text "pattern"
813 pprRFC (HsRecFieldUpd {}) = text "update"
814
815 {-
816 ************************************************************************
817 * *
818 \subsubsection{Literals}
819 * *
820 ************************************************************************
821
822 When literals occur we have to make sure
823 that the types and classes they involve
824 are made available.
825 -}
826
827 rnLit :: HsLit p -> RnM ()
828 rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)
829 rnLit _ = return ()
830
831 -- Turn a Fractional-looking literal which happens to be an integer into an
832 -- Integer-looking literal.
833 generalizeOverLitVal :: OverLitVal -> OverLitVal
834 generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))
835 | denominator val == 1 = HsIntegral (IL { il_text=src
836 , il_neg=neg
837 , il_value=numerator val})
838 generalizeOverLitVal lit = lit
839
840 isNegativeZeroOverLit :: HsOverLit t -> Bool
841 isNegativeZeroOverLit lit
842 = case ol_val lit of
843 HsIntegral i -> 0 == il_value i && il_neg i
844 HsFractional f -> 0 == fl_value f && fl_neg f
845 _ -> False
846
847 {-
848 Note [Negative zero]
849 ~~~~~~~~~~~~~~~~~~~~~~~~~
850 There were problems with negative zero in conjunction with Negative Literals
851 extension. Numeric literal value is contained in Integer and Rational types
852 inside IntegralLit and FractionalLit. These types cannot represent negative
853 zero value. So we had to add explicit field 'neg' which would hold information
854 about literal sign. Here in rnOverLit we use it to detect negative zeroes and
855 in this case return not only literal itself but also negateName so that users
856 can apply it explicitly. In this case it stays negative zero. Trac #13211
857 -}
858
859 rnOverLit :: HsOverLit t ->
860 RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
861 rnOverLit origLit
862 = do { opt_NumDecimals <- xoptM LangExt.NumDecimals
863 ; let { lit@(OverLit {ol_val=val})
864 | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}
865 | otherwise = origLit
866 }
867 ; let std_name = hsOverLitName val
868 ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)
869 <- lookupSyntaxName std_name
870 ; let rebindable = case from_thing_name of
871 HsVar _ lv -> (unLoc lv) /= std_name
872 _ -> panic "rnOverLit"
873 ; let lit' = lit { ol_witness = from_thing_name
874 , ol_ext = rebindable }
875 ; if isNegativeZeroOverLit lit'
876 then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)
877 <- lookupSyntaxName negateName
878 ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
879 , fvs1 `plusFV` fvs2) }
880 else return ((lit', Nothing), fvs1) }
881
882 {-
883 ************************************************************************
884 * *
885 \subsubsection{Errors}
886 * *
887 ************************************************************************
888 -}
889
890 patSigErr :: Outputable a => a -> SDoc
891 patSigErr ty
892 = (text "Illegal signature in pattern:" <+> ppr ty)
893 $$ nest 4 (text "Use ScopedTypeVariables to permit it")
894
895 bogusCharError :: Char -> SDoc
896 bogusCharError c
897 = text "character literal out of range: '\\" <> char c <> char '\''
898
899 badViewPat :: Pat GhcPs -> SDoc
900 badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,
901 text "Use ViewPatterns to enable view patterns"]