TTG3 Combined Step 1 and 3 for Trees That Grow
[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 {-# LANGUAGE FlexibleContexts #-}
15 {-# LANGUAGE TypeFamilies #-}
16
17 module RnPat (-- main entry points
18 rnPat, rnPats, rnBindPat, rnPatAndThen,
19
20 NameMaker, applyNameMaker, -- a utility for making names:
21 localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names,
22 -- sometimes we want to make top (qualified) names.
23 isTopRecNameMaker,
24
25 rnHsRecFields, HsRecFieldContext(..),
26 rnHsRecUpdFields,
27
28 -- CpsRn monad
29 CpsRn, liftCps,
30
31 -- Literals
32 rnLit, rnOverLit,
33
34 -- Pattern Error messages that are also used elsewhere
35 checkTupSize, patSigErr
36 ) where
37
38 -- ENH: thin imports to only what is necessary for patterns
39
40 import GhcPrelude
41
42 import {-# SOURCE #-} RnExpr ( rnLExpr )
43 import {-# SOURCE #-} RnSplice ( rnSplicePat )
44
45 #include "HsVersions.h"
46
47 import HsSyn
48 import TcRnMonad
49 import TcHsSyn ( hsOverLitName )
50 import RnEnv
51 import RnFixity
52 import RnUtils ( HsDocContext(..), newLocalBndrRn, bindLocalNames
53 , warnUnusedMatches, newLocalBndrRn
54 , checkDupNames, checkDupAndShadowedNames
55 , checkTupSize , unknownSubordinateErr )
56 import RnUnbound ( mkUnboundName )
57 import RnTypes
58 import PrelNames
59 import TyCon ( tyConName )
60 import ConLike
61 import Type ( TyThing(..) )
62 import Name
63 import NameSet
64 import OccName ( setOccNameSpace, tcName )
65 import RdrName
66 import BasicTypes
67 import Util
68 import ListSetOps ( removeDups )
69 import Outputable
70 import SrcLoc
71 import Literal ( inCharRange )
72 import TysWiredIn ( nilDataCon )
73 import DataCon
74 import qualified GHC.LanguageExtensions as LangExt
75
76 import Control.Monad ( when, liftM, ap )
77 import qualified Data.List.NonEmpty as NE
78 import Data.Ratio
79
80 {-
81 *********************************************************
82 * *
83 The CpsRn Monad
84 * *
85 *********************************************************
86
87 Note [CpsRn monad]
88 ~~~~~~~~~~~~~~~~~~
89 The CpsRn monad uses continuation-passing style to support this
90 style of programming:
91
92 do { ...
93 ; ns <- bindNames rs
94 ; ...blah... }
95
96 where rs::[RdrName], ns::[Name]
97
98 The idea is that '...blah...'
99 a) sees the bindings of ns
100 b) returns the free variables it mentions
101 so that bindNames can report unused ones
102
103 In particular,
104 mapM rnPatAndThen [p1, p2, p3]
105 has a *left-to-right* scoping: it makes the binders in
106 p1 scope over p2,p3.
107 -}
108
109 newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
110 -> RnM (r, FreeVars) }
111 -- See Note [CpsRn monad]
112
113 instance Functor CpsRn where
114 fmap = liftM
115
116 instance Applicative CpsRn where
117 pure x = CpsRn (\k -> k x)
118 (<*>) = ap
119
120 instance Monad CpsRn where
121 (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
122
123 runCps :: CpsRn a -> RnM (a, FreeVars)
124 runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
125
126 liftCps :: RnM a -> CpsRn a
127 liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
128
129 liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
130 liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
131 ; (r,fvs2) <- k v
132 ; return (r, fvs1 `plusFV` fvs2) })
133
134 wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)
135 -- Set the location, and also wrap it around the value returned
136 wrapSrcSpanCps fn (L loc a)
137 = CpsRn (\k -> setSrcSpan loc $
138 unCpsRn (fn a) $ \v ->
139 k (L 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 PatCtx sig)
222
223 newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
224 newPatLName name_maker rdr_name@(L loc _)
225 = do { name <- newPatName name_maker rdr_name
226 ; return (L 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 (L l rdr)) = do { loc <- liftCps getSrcSpanM
396 ; name <- newPatName mk (L loc rdr)
397 ; return (VarPat x (L l name)) }
398 -- we need to bind pattern variables for view pattern expressions
399 -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
400
401 rnPatAndThen mk (SigPat sig pat )
402 -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
403 -- important to rename its type signature _before_ renaming the rest of the
404 -- pattern, so that type variables are first bound by the _outermost_ pattern
405 -- type signature they occur in. This keeps the type checker happy when
406 -- pattern type signatures happen to be nested (#7827)
407 --
408 -- f ((Just (x :: a) :: Maybe a)
409 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here
410 -- ~~~~~~~~~~~~~~~^ the same `a' then used here
411 = do { sig' <- rnHsSigCps sig
412 ; pat' <- rnLPatAndThen mk pat
413 ; return (SigPat sig' pat' ) }
414
415 rnPatAndThen mk (LitPat x lit)
416 | HsString src s <- lit
417 = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
418 ; if ovlStr
419 then rnPatAndThen mk
420 (mkNPat (noLoc (mkHsIsString src s))
421 Nothing)
422 else normal_lit }
423 | otherwise = normal_lit
424 where
425 normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
426
427 rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
428 = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
429 ; mb_neg' -- See Note [Negative zero]
430 <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName
431 ; return (Just neg, fvs) }
432 positive = return (Nothing, emptyFVs)
433 in liftCpsFV $ case (mb_neg , mb_neg') of
434 (Nothing, Just _ ) -> negative
435 (Just _ , Nothing) -> negative
436 (Nothing, Nothing) -> positive
437 (Just _ , Just _ ) -> positive
438 ; eq' <- liftCpsFV $ lookupSyntaxName eqName
439 ; return (NPat x (L l lit') mb_neg' eq') }
440
441 rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )
442 = do { new_name <- newPatName mk rdr
443 ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
444 -- We skip negateName as
445 -- negative zero doesn't make
446 -- sense in n + k patterns
447 ; minus <- liftCpsFV $ lookupSyntaxName minusName
448 ; ge <- liftCpsFV $ lookupSyntaxName geName
449 ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name)
450 (L l lit') lit' ge minus) }
451 -- The Report says that n+k patterns must be in Integral
452
453 rnPatAndThen mk (AsPat x rdr pat)
454 = do { new_name <- newPatLName mk rdr
455 ; pat' <- rnLPatAndThen mk pat
456 ; return (AsPat x new_name pat') }
457
458 rnPatAndThen mk p@(ViewPat x expr pat)
459 = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
460 ; checkErr vp_flag (badViewPat p) }
461 -- Because of the way we're arranging the recursive calls,
462 -- this will be in the right context
463 ; expr' <- liftCpsFV $ rnLExpr expr
464 ; pat' <- rnLPatAndThen mk pat
465 -- Note: at this point the PreTcType in ty can only be a placeHolder
466 -- ; return (ViewPat expr' pat' ty) }
467 ; return (ViewPat x expr' pat') }
468
469 rnPatAndThen mk (ConPatIn con stuff)
470 -- rnConPatAndThen takes care of reconstructing the pattern
471 -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
472 = case unLoc con == nameRdrName (dataConName nilDataCon) of
473 True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
474 ; if ol_flag then rnPatAndThen mk (ListPat noExt []
475 placeHolderType Nothing)
476 else rnConPatAndThen mk con stuff}
477 False -> rnConPatAndThen mk con stuff
478
479 rnPatAndThen mk (ListPat x 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 x pats' placeHolderType
485 (Just (placeHolderType, to_list_name)))}
486 False -> return (ListPat x pats' placeHolderType Nothing) }
487
488 rnPatAndThen mk (PArrPat x pats)
489 = do { pats' <- rnLPatsAndThen mk pats
490 ; return (PArrPat x pats') }
491
492 rnPatAndThen mk (TuplePat x pats boxed)
493 = do { liftCps $ checkTupSize (length pats)
494 ; pats' <- rnLPatsAndThen mk pats
495 ; return (TuplePat x pats' boxed) }
496
497 rnPatAndThen mk (SumPat x pat alt arity)
498 = do { pat <- rnLPatAndThen mk pat
499 ; return (SumPat x pat alt arity)
500 }
501
502 -- If a splice has been run already, just rename the result.
503 rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))
504 = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat
505
506 rnPatAndThen mk (SplicePat _ splice)
507 = do { eith <- liftCpsFV $ rnSplicePat splice
508 ; case eith of -- See Note [rnSplicePat] in RnSplice
509 Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed
510 Right already_renamed -> return already_renamed }
511
512 rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
513
514
515 --------------------
516 rnConPatAndThen :: NameMaker
517 -> Located RdrName -- the constructor
518 -> HsConPatDetails GhcPs
519 -> CpsRn (Pat GhcRn)
520
521 rnConPatAndThen mk con (PrefixCon pats)
522 = do { con' <- lookupConCps con
523 ; pats' <- rnLPatsAndThen mk pats
524 ; return (ConPatIn con' (PrefixCon pats')) }
525
526 rnConPatAndThen mk con (InfixCon pat1 pat2)
527 = do { con' <- lookupConCps con
528 ; pat1' <- rnLPatAndThen mk pat1
529 ; pat2' <- rnLPatAndThen mk pat2
530 ; fixity <- liftCps $ lookupFixityRn (unLoc con')
531 ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
532
533 rnConPatAndThen mk con (RecCon rpats)
534 = do { con' <- lookupConCps con
535 ; rpats' <- rnHsRecPatsAndThen mk con' rpats
536 ; return (ConPatIn con' (RecCon rpats')) }
537
538 --------------------
539 rnHsRecPatsAndThen :: NameMaker
540 -> Located Name -- Constructor
541 -> HsRecFields GhcPs (LPat GhcPs)
542 -> CpsRn (HsRecFields GhcRn (LPat GhcRn))
543 rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd })
544 = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
545 hs_rec_fields
546 ; flds' <- mapM rn_field (flds `zip` [1..])
547 ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
548 where
549 mkVarPat l n = VarPat noExt (L l n)
550 rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n')
551 (hsRecFieldArg fld)
552 ; return (L l (fld { hsRecFieldArg = arg' })) }
553
554 -- Suppress unused-match reporting for fields introduced by ".."
555 nested_mk Nothing mk _ = mk
556 nested_mk (Just _) mk@(LetMk {}) _ = mk
557 nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n))
558
559 {-
560 ************************************************************************
561 * *
562 Record fields
563 * *
564 ************************************************************************
565 -}
566
567 data HsRecFieldContext
568 = HsRecFieldCon Name
569 | HsRecFieldPat Name
570 | HsRecFieldUpd
571
572 rnHsRecFields
573 :: forall arg.
574 HsRecFieldContext
575 -> (SrcSpan -> RdrName -> arg)
576 -- When punning, use this to build a new field
577 -> HsRecFields GhcPs (Located arg)
578 -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars)
579
580 -- This surprisingly complicated pass
581 -- a) looks up the field name (possibly using disambiguation)
582 -- b) fills in puns and dot-dot stuff
583 -- When we we've finished, we've renamed the LHS, but not the RHS,
584 -- of each x=e binding
585 --
586 -- This is used for record construction and pattern-matching, but not updates.
587
588 rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
589 = do { pun_ok <- xoptM LangExt.RecordPuns
590 ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
591 ; parent <- check_disambiguation disambig_ok mb_con
592 ; flds1 <- mapM (rn_fld pun_ok parent) flds
593 ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
594 ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
595 ; let all_flds | null dotdot_flds = flds1
596 | otherwise = flds1 ++ dotdot_flds
597 ; return (all_flds, mkFVs (getFieldIds all_flds)) }
598 where
599 mb_con = case ctxt of
600 HsRecFieldCon con -> Just con
601 HsRecFieldPat con -> Just con
602 _ {- update -} -> Nothing
603
604 doc = case mb_con of
605 Nothing -> text "constructor field name"
606 Just con -> text "field of constructor" <+> quotes (ppr con)
607
608 rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)
609 -> RnM (LHsRecField GhcRn (Located arg))
610 rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl
611 = L loc (FieldOcc _ (L ll lbl))
612 , hsRecFieldArg = arg
613 , hsRecPun = pun }))
614 = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl
615 ; arg' <- if pun
616 then do { checkErr pun_ok (badPun (L loc lbl))
617 -- Discard any module qualifier (#11662)
618 ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
619 ; return (L loc (mk_arg loc arg_rdr)) }
620 else return arg
621 ; return (L l (HsRecField { hsRecFieldLbl
622 = L loc (FieldOcc sel (L ll lbl))
623 , hsRecFieldArg = arg'
624 , hsRecPun = pun })) }
625 rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _))
626 = panic "rnHsRecFields"
627
628 rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat
629 -> Maybe Name -- The constructor (Nothing for an
630 -- out of scope constructor)
631 -> [LHsRecField GhcRn (Located arg)] -- Explicit fields
632 -> RnM [LHsRecField GhcRn (Located arg)] -- Filled in .. fields
633 rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
634 | not (isUnboundName con) -- This test is because if the constructor
635 -- isn't in scope the constructor lookup will add
636 -- an error but still return an unbound name. We
637 -- don't want that to screw up the dot-dot fill-in stuff.
638 = ASSERT( flds `lengthIs` n )
639 do { loc <- getSrcSpanM -- Rather approximate
640 ; dd_flag <- xoptM LangExt.RecordWildCards
641 ; checkErr dd_flag (needFlagDotDot ctxt)
642 ; (rdr_env, lcl_env) <- getRdrEnvs
643 ; con_fields <- lookupConstructorFields con
644 ; when (null con_fields) (addErr (badDotDotCon con))
645 ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
646
647 -- For constructor uses (but not patterns)
648 -- the arg should be in scope locally;
649 -- i.e. not top level or imported
650 -- Eg. data R = R { x,y :: Int }
651 -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y}
652 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env
653
654 (dot_dot_fields, dot_dot_gres)
655 = unzip [ (fl, gre)
656 | fl <- con_fields
657 , let lbl = mkVarOccFS (flLabel fl)
658 , not (lbl `elemOccSet` present_flds)
659 , Just gre <- [lookupGRE_FieldLabel rdr_env fl]
660 -- Check selector is in scope
661 , case ctxt of
662 HsRecFieldCon {} -> arg_in_scope lbl
663 _other -> True ]
664
665 ; addUsedGREs dot_dot_gres
666 ; return [ L loc (HsRecField
667 { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr))
668 , hsRecFieldArg = L loc (mk_arg loc arg_rdr)
669 , hsRecPun = False })
670 | fl <- dot_dot_fields
671 , let sel = flSelector fl
672 , let arg_rdr = mkVarUnqual (flLabel fl) ] }
673
674 rn_dotdot _dotdot _mb_con _flds
675 = return []
676 -- _dotdot = Nothing => No ".." at all
677 -- _mb_con = Nothing => Record update
678 -- _mb_con = Just unbound => Out of scope data constructor
679
680 check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
681 -- When disambiguation is on, return name of parent tycon.
682 check_disambiguation disambig_ok mb_con
683 | disambig_ok, Just con <- mb_con
684 = do { env <- getGlobalRdrEnv; return (find_tycon env con) }
685 | otherwise = return Nothing
686
687 find_tycon :: GlobalRdrEnv -> Name {- DataCon -}
688 -> Maybe Name {- TyCon -}
689 -- Return the parent *type constructor* of the data constructor
690 -- (that is, the parent of the data constructor),
691 -- or 'Nothing' if it is a pattern synonym or not in scope.
692 -- That's the parent to use for looking up record fields.
693 find_tycon env con_name
694 | isUnboundName con_name
695 = Just (mkUnboundName (setOccNameSpace tcName (getOccName con_name)))
696 -- If the data con is not in scope, return an unboundName tycon
697 -- That way the calls to lookupRecFieldOcc in rn_fld won't generate
698 -- an error cascade; see Trac #14307
699
700 | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con_name
701 = Just (tyConName (dataConTyCon dc))
702 -- Special case for [], which is built-in syntax
703 -- and not in the GlobalRdrEnv (Trac #8448)
704
705 | Just gre <- lookupGRE_Name env con_name
706 = case gre_par gre of
707 ParentIs p -> Just p
708 _ -> Nothing -- Can happen if the con_name
709 -- is for a pattern synonym
710
711 | otherwise = Nothing
712 -- Data constructor not lexically in scope at all
713 -- See Note [Disambiguation and Template Haskell]
714
715 dup_flds :: [NE.NonEmpty RdrName]
716 -- Each list represents a RdrName that occurred more than once
717 -- (the list contains all occurrences)
718 -- Each list in dup_fields is non-empty
719 (_, dup_flds) = removeDups compare (getFieldLbls flds)
720
721
722 {- Note [Disambiguation and Template Haskell]
723 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
724 Consider (Trac #12130)
725 module Foo where
726 import M
727 b = $(funny)
728
729 module M(funny) where
730 data T = MkT { x :: Int }
731 funny :: Q Exp
732 funny = [| MkT { x = 3 } |]
733
734 When we splice, neither T nor MkT are lexically in scope, so find_tycon will
735 fail. But there is no need for disambiguation anyway, so we just return Nothing
736 -}
737
738 rnHsRecUpdFields
739 :: [LHsRecUpdField GhcPs]
740 -> RnM ([LHsRecUpdField GhcRn], FreeVars)
741 rnHsRecUpdFields flds
742 = do { pun_ok <- xoptM LangExt.RecordPuns
743 ; overload_ok <- xoptM LangExt.DuplicateRecordFields
744 ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds
745 ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
746
747 -- Check for an empty record update e {}
748 -- NB: don't complain about e { .. }, because rn_dotdot has done that already
749 ; when (null flds) $ addErr emptyUpdateErr
750
751 ; return (flds1, plusFVs fvss) }
752 where
753 doc = text "constructor field name"
754
755 rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs
756 -> RnM (LHsRecUpdField GhcRn, FreeVars)
757 rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f
758 , hsRecFieldArg = arg
759 , hsRecPun = pun }))
760 = do { let lbl = rdrNameAmbiguousFieldOcc f
761 ; sel <- setSrcSpan loc $
762 -- Defer renaming of overloaded fields to the typechecker
763 -- See Note [Disambiguating record fields] in TcExpr
764 if overload_ok
765 then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl
766 ; case mb of
767 Nothing -> do { addErr (unknownSubordinateErr doc lbl)
768 ; return (Right []) }
769 Just r -> return r }
770 else fmap Left $ lookupGlobalOccRn lbl
771 ; arg' <- if pun
772 then do { checkErr pun_ok (badPun (L loc lbl))
773 -- Discard any module qualifier (#11662)
774 ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
775 ; return (L loc (HsVar noExt (L loc arg_rdr))) }
776 else return arg
777 ; (arg'', fvs) <- rnLExpr arg'
778
779 ; let fvs' = case sel of
780 Left sel_name -> fvs `addOneFV` sel_name
781 Right [sel_name] -> fvs `addOneFV` sel_name
782 Right _ -> fvs
783 lbl' = case sel of
784 Left sel_name ->
785 L loc (Unambiguous sel_name (L loc lbl))
786 Right [sel_name] ->
787 L loc (Unambiguous sel_name (L loc lbl))
788 Right _ -> L loc (Ambiguous noExt (L loc lbl))
789
790 ; return (L l (HsRecField { hsRecFieldLbl = lbl'
791 , hsRecFieldArg = arg''
792 , hsRecPun = pun }), fvs') }
793
794 dup_flds :: [NE.NonEmpty RdrName]
795 -- Each list represents a RdrName that occurred more than once
796 -- (the list contains all occurrences)
797 -- Each list in dup_fields is non-empty
798 (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
799
800
801
802 getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
803 getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds
804
805 getFieldLbls :: [LHsRecField id arg] -> [RdrName]
806 getFieldLbls flds
807 = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
808
809 getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
810 getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
811
812 needFlagDotDot :: HsRecFieldContext -> SDoc
813 needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,
814 text "Use RecordWildCards to permit this"]
815
816 badDotDotCon :: Name -> SDoc
817 badDotDotCon con
818 = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)
819 , nest 2 (text "The constructor has no labelled fields") ]
820
821 emptyUpdateErr :: SDoc
822 emptyUpdateErr = text "Empty record update"
823
824 badPun :: Located RdrName -> SDoc
825 badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
826 text "Use NamedFieldPuns to permit this"]
827
828 dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc
829 dupFieldErr ctxt dups
830 = hsep [text "duplicate field name",
831 quotes (ppr (NE.head dups)),
832 text "in record", pprRFC ctxt]
833
834 pprRFC :: HsRecFieldContext -> SDoc
835 pprRFC (HsRecFieldCon {}) = text "construction"
836 pprRFC (HsRecFieldPat {}) = text "pattern"
837 pprRFC (HsRecFieldUpd {}) = text "update"
838
839 {-
840 ************************************************************************
841 * *
842 \subsubsection{Literals}
843 * *
844 ************************************************************************
845
846 When literals occur we have to make sure
847 that the types and classes they involve
848 are made available.
849 -}
850
851 rnLit :: HsLit p -> RnM ()
852 rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)
853 rnLit _ = return ()
854
855 -- Turn a Fractional-looking literal which happens to be an integer into an
856 -- Integer-looking literal.
857 generalizeOverLitVal :: OverLitVal -> OverLitVal
858 generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))
859 | denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val})
860 generalizeOverLitVal lit = lit
861
862 isNegativeZeroOverLit :: HsOverLit t -> Bool
863 isNegativeZeroOverLit lit
864 = case ol_val lit of
865 HsIntegral i -> 0 == il_value i && il_neg i
866 HsFractional f -> 0 == fl_value f && fl_neg f
867 _ -> False
868
869 {-
870 Note [Negative zero]
871 ~~~~~~~~~~~~~~~~~~~~~~~~~
872 There were problems with negative zero in conjunction with Negative Literals
873 extension. Numeric literal value is contained in Integer and Rational types
874 inside IntegralLit and FractionalLit. These types cannot represent negative
875 zero value. So we had to add explicit field 'neg' which would hold information
876 about literal sign. Here in rnOverLit we use it to detect negative zeroes and
877 in this case return not only literal itself but also negateName so that users
878 can apply it explicitly. In this case it stays negative zero. Trac #13211
879 -}
880
881 rnOverLit :: HsOverLit t ->
882 RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
883 rnOverLit origLit
884 = do { opt_NumDecimals <- xoptM LangExt.NumDecimals
885 ; let { lit@(OverLit {ol_val=val})
886 | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}
887 | otherwise = origLit
888 }
889 ; let std_name = hsOverLitName val
890 ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)
891 <- lookupSyntaxName std_name
892 ; let rebindable = case from_thing_name of
893 HsVar _ (L _ v) -> v /= std_name
894 _ -> panic "rnOverLit"
895 ; let lit' = lit { ol_witness = from_thing_name
896 , ol_ext = rebindable }
897 ; if isNegativeZeroOverLit lit'
898 then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)
899 <- lookupSyntaxName negateName
900 ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
901 , fvs1 `plusFV` fvs2) }
902 else return ((lit', Nothing), fvs1) }
903
904 {-
905 ************************************************************************
906 * *
907 \subsubsection{Errors}
908 * *
909 ************************************************************************
910 -}
911
912 patSigErr :: Outputable a => a -> SDoc
913 patSigErr ty
914 = (text "Illegal signature in pattern:" <+> ppr ty)
915 $$ nest 4 (text "Use ScopedTypeVariables to permit it")
916
917 bogusCharError :: Char -> SDoc
918 bogusCharError c
919 = text "character literal out of range: '\\" <> char c <> char '\''
920
921 badViewPat :: Pat GhcPs -> SDoc
922 badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,
923 text "Use ViewPatterns to enable view patterns"]