Commit 6fb8a6ab authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix Trac #5372: a panic caused by over-eager error recovery

parent 459fb7bc
......@@ -10,6 +10,7 @@ general, all of these functions return a renamed thing, and a set of
free variables.
\begin{code}
{-# LANGUAGE ScopedTypeVariables #-}
module RnPat (-- main entry points
rnPat, rnPats, rnBindPat,
......@@ -441,7 +442,8 @@ data HsRecFieldContext
| HsRecFieldUpd
rnHsRecFields1
:: HsRecFieldContext
:: forall arg.
HsRecFieldContext
-> (RdrName -> arg) -- When punning, use this to build a new field
-> HsRecFields RdrName (Located arg)
-> RnM ([HsRecField Name (Located arg)], FreeVars)
......@@ -458,13 +460,20 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
; parent <- check_disambiguation disambig_ok mb_con
; flds1 <- mapM (rn_fld pun_ok parent) flds
; mapM_ (addErr . dupFieldErr ctxt) dup_flds
; flds2 <- rn_dotdot dotdot mb_con flds1
; return (flds2, mkFVs (getFieldIds flds2)) }
; dotdot_flds <- rn_dotdot dotdot mb_con flds1
; let all_flds | null dotdot_flds = flds1
| otherwise = flds1 ++ dotdot_flds
; return (all_flds, mkFVs (getFieldIds all_flds)) }
where
mb_con = case ctxt of
HsRecFieldUpd -> Nothing
HsRecFieldCon con -> Just con
HsRecFieldPat con -> Just con
HsRecFieldCon con | not (isUnboundName con) -> Just con
HsRecFieldPat con | not (isUnboundName con) -> Just con
_other -> Nothing
-- The unbound name test is because if the constructor
-- isn't in scope the constructor lookup will add an error
-- add an error, but still return an unbound name.
-- We don't want that to screw up the dot-dot fill-in stuff.
doc = case mb_con of
Nothing -> ptext (sLit "constructor field name")
Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con)
......@@ -481,10 +490,15 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
, hsRecFieldArg = arg'
, hsRecPun = pun }) }
rn_dotdot Nothing _mb_con flds -- No ".." at all
= return flds
rn_dotdot (Just {}) Nothing flds -- ".." on record update
= do { addErr (badDotDot ctxt); return flds }
rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat
-> Maybe Name -- The constructor (Nothing for an update
-- or out of scope constructor)
-> [HsRecField Name (Located arg)] -- Explicit fields
-> RnM [HsRecField Name (Located arg)] -- Filled in .. fields
rn_dotdot Nothing _mb_con _flds -- No ".." at all
= return []
rn_dotdot (Just {}) Nothing _flds -- ".." on record update
= do { addErr (badDotDot ctxt); return [] }
rn_dotdot (Just n) (Just con) flds -- ".." on record con/pat
= ASSERT( n == length flds )
do { loc <- getSrcSpanM -- Rather approximate
......@@ -494,18 +508,6 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
; con_fields <- lookupConstructorFields con
; let present_flds = getFieldIds flds
parent_tc = find_tycon rdr_env con
extras = [ HsRecField
{ hsRecFieldId = loc_f
, hsRecFieldArg = L loc (mk_arg arg_rdr)
, hsRecPun = False }
| f <- con_fields
, let loc_f = L loc f
arg_rdr = mkRdrUnqual (nameOccName f)
, not (f `elem` present_flds)
, fld_in_scope f
, case ctxt of
HsRecFieldCon {} -> arg_in_scope arg_rdr
_other -> True ]
-- Only fill in fields whose selectors are in scope (somehow)
fld_in_scope fld = not (null (lookupGRE_Name rdr_env fld))
......@@ -520,7 +522,18 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
ParentIs p -> p /= parent_tc
_ -> True ]
; return (flds ++ extras) }
; return [ HsRecField
{ hsRecFieldId = loc_f
, hsRecFieldArg = L loc (mk_arg arg_rdr)
, hsRecPun = False }
| f <- con_fields
, let loc_f = L loc f
arg_rdr = mkRdrUnqual (nameOccName f)
, not (f `elem` present_flds)
, fld_in_scope f
, case ctxt of
HsRecFieldCon {} -> arg_in_scope arg_rdr
_other -> True ] }
check_disambiguation :: Bool -> Maybe Name -> RnM Parent
-- When disambiguation is on,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment