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