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