Commit 0a163741 authored by Adam Gundry's avatar Adam Gundry

Disambiguate record selectors by type signature

This makes DuplicateRecordFields more liberal in when it will
accept ambiguous record selectors, making use of type information in a
similar way to updates. See Note [Disambiguating record fields] for more
details. I've also refactored how record updates are disambiguated.

Test Plan: New and amended tests in overloadedrecflds

Reviewers: simonpj, goldfire, bgamari, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1391
parent 268aa9a2
...@@ -711,7 +711,7 @@ dsExpr (EViewPat {}) = panic "dsExpr:EViewPat" ...@@ -711,7 +711,7 @@ dsExpr (EViewPat {}) = panic "dsExpr:EViewPat"
dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat" dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat"
dsExpr (HsType {}) = panic "dsExpr:HsType" dsExpr (HsType {}) = panic "dsExpr:HsType"
dsExpr (HsDo {}) = panic "dsExpr:HsDo" dsExpr (HsDo {}) = panic "dsExpr:HsDo"
dsExpr (HsSingleRecFld{}) = panic "dsExpr: HsSingleRecFld" dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld"
findField :: [LHsRecField Id arg] -> Name -> [arg] findField :: [LHsRecField Id arg] -> Name -> [arg]
......
...@@ -1073,6 +1073,10 @@ repE (HsVar x) = ...@@ -1073,6 +1073,10 @@ repE (HsVar x) =
; return (MkC e') } } ; return (MkC e') } }
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE e@(HsRecFld f) = case f of
Unambiguous _ x -> repE (HsVar x)
Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
-- Remember, we're desugaring renamer output here, so -- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur -- HsOverlit can definitely occur
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
...@@ -1241,7 +1245,7 @@ repUpdFields = repList fieldExpQTyConName rep_fld ...@@ -1241,7 +1245,7 @@ repUpdFields = repList fieldExpQTyConName rep_fld
Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name) Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)
; e <- repLE (hsRecFieldArg fld) ; e <- repLE (hsRecFieldArg fld)
; repFieldExp fn e } ; repFieldExp fn e }
_ -> notHandled "ambiguous record updates" (ppr fld) _ -> notHandled "Ambiguous record updates" (ppr fld)
......
...@@ -135,7 +135,7 @@ data HsExpr id ...@@ -135,7 +135,7 @@ data HsExpr id
-- Turned into HsVar by type checker, to support deferred -- Turned into HsVar by type checker, to support deferred
-- type errors. (The HsUnboundVar only has an OccName.) -- type errors. (The HsUnboundVar only has an OccName.)
| HsSingleRecFld (FieldOcc id) -- ^ Variable that corresponds to a record selector | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector
| HsIPVar HsIPName -- ^ Implicit parameter | HsIPVar HsIPName -- ^ Implicit parameter
| HsOverLit (HsOverLit id) -- ^ Overloaded literals | HsOverLit (HsOverLit id) -- ^ Overloaded literals
...@@ -801,7 +801,7 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) ...@@ -801,7 +801,7 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
ppr_expr (HsArrForm op _ args) ppr_expr (HsArrForm op _ args)
= hang (ptext (sLit "(|") <+> ppr_lexpr op) = hang (ptext (sLit "(|") <+> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)")) 4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
ppr_expr (HsSingleRecFld f) = ppr f ppr_expr (HsRecFld f) = ppr f
pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
...@@ -853,7 +853,7 @@ hsExprNeedsParens (HsRnBracketOut {}) = False ...@@ -853,7 +853,7 @@ hsExprNeedsParens (HsRnBracketOut {}) = False
hsExprNeedsParens (HsTcBracketOut {}) = False hsExprNeedsParens (HsTcBracketOut {}) = False
hsExprNeedsParens (HsDo sc _ _) hsExprNeedsParens (HsDo sc _ _)
| isListCompExpr sc = False | isListCompExpr sc = False
hsExprNeedsParens (HsSingleRecFld{}) = False hsExprNeedsParens (HsRecFld{}) = False
hsExprNeedsParens _ = True hsExprNeedsParens _ = True
...@@ -866,7 +866,7 @@ isAtomicHsExpr (HsIPVar {}) = True ...@@ -866,7 +866,7 @@ isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsUnboundVar {}) = True isAtomicHsExpr (HsUnboundVar {}) = True
isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
isAtomicHsExpr (HsSingleRecFld{}) = True isAtomicHsExpr (HsRecFld{}) = True
isAtomicHsExpr _ = False isAtomicHsExpr _ = False
{- {-
......
...@@ -324,6 +324,8 @@ data HsRecField' id arg = HsRecField { ...@@ -324,6 +324,8 @@ data HsRecField' id arg = HsRecField {
-- The typechecker will determine the particular selector: -- The typechecker will determine the particular selector:
-- --
-- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id -- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id
--
-- See also Note [Disambiguating record fields] in TcExpr.
hsRecFields :: HsRecFields id arg -> [PostRn id id] hsRecFields :: HsRecFields id arg -> [PostRn id id]
hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)
......
...@@ -587,7 +587,8 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder ...@@ -587,7 +587,8 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder
-- (for unambiguous occurrences) or the typechecker (for ambiguous -- (for unambiguous occurrences) or the typechecker (for ambiguous
-- occurrences). -- occurrences).
-- --
-- See Note [HsRecField and HsRecUpdField] in HsPat -- See Note [HsRecField and HsRecUpdField] in HsPat and
-- Note [Disambiguating record fields] in TcExpr.
data AmbiguousFieldOcc name data AmbiguousFieldOcc name
= Unambiguous RdrName (PostRn name name) = Unambiguous RdrName (PostRn name name)
| Ambiguous RdrName (PostTc name name) | Ambiguous RdrName (PostTc name name)
...@@ -615,7 +616,7 @@ unambiguousFieldOcc :: AmbiguousFieldOcc Id -> FieldOcc Id ...@@ -615,7 +616,7 @@ unambiguousFieldOcc :: AmbiguousFieldOcc Id -> FieldOcc Id
unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel
ambiguousFieldOcc :: FieldOcc Id -> AmbiguousFieldOcc Id ambiguousFieldOcc :: FieldOcc name -> AmbiguousFieldOcc name
ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
{- {-
......
...@@ -16,6 +16,7 @@ module RnEnv ( ...@@ -16,6 +16,7 @@ module RnEnv (
lookupGlobalOccRn, lookupGlobalOccRn_maybe, lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
reportUnboundName, unknownNameSuggestions, reportUnboundName, unknownNameSuggestions,
addNameClashErrRn,
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
lookupSigCtxtOccRn, lookupSigCtxtOccRn,
......
...@@ -94,7 +94,8 @@ rnUnboundVar v ...@@ -94,7 +94,8 @@ rnUnboundVar v
; return (HsVar n, emptyFVs) } } ; return (HsVar n, emptyFVs) } }
rnExpr (HsVar v) rnExpr (HsVar v)
= do { mb_name <- lookupOccRn_overloaded False v = do { opt_DuplicateRecordFields <- xoptM Opt_DuplicateRecordFields
; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
; case mb_name of { ; case mb_name of {
Nothing -> rnUnboundVar v ; Nothing -> rnUnboundVar v ;
Just (Left name) Just (Left name)
...@@ -104,9 +105,11 @@ rnExpr (HsVar v) ...@@ -104,9 +105,11 @@ rnExpr (HsVar v)
| otherwise | otherwise
-> finishHsVar name ; -> finishHsVar name ;
Just (Right (f:fs)) -> ASSERT( null fs ) Just (Right [f]) -> return (HsRecFld (ambiguousFieldOcc f)
return (HsSingleRecFld f, unitFV (selectorFieldOcc f)) ; , unitFV (selectorFieldOcc f)) ;
Just (Right []) -> error "runExpr/HsVar" } } Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous v PlaceHolder)
, mkFVs (map selectorFieldOcc fs));
Just (Right []) -> error "runExpr/HsVar" } }
rnExpr (HsIPVar v) rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs) = return (HsIPVar v, emptyFVs)
......
...@@ -672,7 +672,7 @@ rnHsRecUpdFields flds ...@@ -672,7 +672,7 @@ rnHsRecUpdFields flds
= do { let lbl = rdrNameAmbiguousFieldOcc f = do { let lbl = rdrNameAmbiguousFieldOcc f
; sel <- setSrcSpan loc $ ; sel <- setSrcSpan loc $
-- Defer renaming of overloaded fields to the typechecker -- Defer renaming of overloaded fields to the typechecker
-- See Note [Disambiguating record updates] in TcExpr -- See Note [Disambiguating record fields] in TcExpr
if overload_ok if overload_ok
then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl
; case mb of ; case mb of
......
...@@ -28,7 +28,9 @@ import BasicTypes ...@@ -28,7 +28,9 @@ import BasicTypes
import Inst import Inst
import TcBinds import TcBinds
import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst ) import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst )
import RnEnv ( addUsedGRE ) import FamInstEnv ( FamInstEnvs )
import RnEnv ( addUsedGRE, addNameClashErrRn
, unknownSubordinateErr )
import TcEnv import TcEnv
import TcArrows import TcArrows
import TcMatches import TcMatches
...@@ -693,7 +695,7 @@ following. ...@@ -693,7 +695,7 @@ following.
tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty
= ASSERT( notNull rbnds ) = ASSERT( notNull rbnds )
do { do {
-- STEP -1 See Note [Disambiguating record updates] -- STEP -1 See Note [Disambiguating record fields]
-- After this we know that rbinds is unambiguous -- After this we know that rbinds is unambiguous
rbinds <- disambiguateRecordBinds record_expr rbnds res_ty rbinds <- disambiguateRecordBinds record_expr rbnds res_ty
; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds
...@@ -826,7 +828,7 @@ tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty ...@@ -826,7 +828,7 @@ tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty
RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
relevant_cons scrut_inst_tys result_inst_tys req_wrap } relevant_cons scrut_inst_tys result_inst_tys req_wrap }
tcExpr (HsSingleRecFld f) res_ty tcExpr (HsRecFld f) res_ty
= tcCheckRecSelId f res_ty = tcCheckRecSelId f res_ty
{- {-
...@@ -973,6 +975,14 @@ tcApp (L loc (HsVar fun)) args res_ty ...@@ -973,6 +975,14 @@ tcApp (L loc (HsVar fun)) args res_ty
, [arg1,arg2] <- args , [arg1,arg2] <- args
= tcSeq loc fun arg1 arg2 res_ty = tcSeq loc fun arg1 arg2 res_ty
-- Look for applications of ambiguous record selectors to arguments
-- with type signatures, see Note [Disambiguating record fields]
tcApp (L loc (HsRecFld (Ambiguous lbl _))) args@(L _ arg:_) res_ty
| Just sig_ty <- obviousSig arg
= do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
; sel_name <- disambiguateSelector lbl sig_tc_ty
; tcApp (L loc (HsRecFld (Unambiguous lbl sel_name))) args res_ty }
tcApp fun args res_ty tcApp fun args res_ty
= do { -- Type-check the function = do { -- Type-check the function
; (fun1, fun_tau) <- tcInferFun fun ; (fun1, fun_tau) <- tcInferFun fun
...@@ -1011,7 +1021,7 @@ tcInferFun (L loc (HsVar name)) ...@@ -1011,7 +1021,7 @@ tcInferFun (L loc (HsVar name))
-- Don't wrap a context around a plain Id -- Don't wrap a context around a plain Id
; return (L loc fun, ty) } ; return (L loc fun, ty) }
tcInferFun (L loc (HsSingleRecFld f)) tcInferFun (L loc (HsRecFld f))
= do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f) = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
-- Don't wrap a context around a plain Id -- Don't wrap a context around a plain Id
; return (L loc fun, ty) } ; return (L loc fun, ty) }
...@@ -1108,19 +1118,27 @@ tcCheckId name res_ty ...@@ -1108,19 +1118,27 @@ tcCheckId name res_ty
; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $ ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
tcWrapResult expr actual_res_ty res_ty } tcWrapResult expr actual_res_ty res_ty }
tcCheckRecSelId :: FieldOcc Name -> TcRhoType -> TcM (HsExpr TcId) tcCheckRecSelId :: AmbiguousFieldOcc Name -> TcRhoType -> TcM (HsExpr TcId)
tcCheckRecSelId f res_ty tcCheckRecSelId f@(Unambiguous _ _) res_ty
= do { (expr, actual_res_ty) <- tcInferRecSelId f = do { (expr, actual_res_ty) <- tcInferRecSelId f
; addErrCtxtM (funResCtxt False (HsSingleRecFld f) actual_res_ty res_ty) $ ; addErrCtxtM (funResCtxt False (HsRecFld f) actual_res_ty res_ty) $
tcWrapResult expr actual_res_ty res_ty } tcWrapResult expr actual_res_ty res_ty }
tcCheckRecSelId (Ambiguous lbl _) res_ty
= case tcSplitFunTy_maybe res_ty of
Nothing -> ambiguousSelector lbl
Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty }
------------------------ ------------------------
tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType) tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
-- Infer type, and deeply instantiate -- Infer type, and deeply instantiate
tcInferId n = tcInferIdWithOrig (OccurrenceOf n) (nameRdrName n) n tcInferId n = tcInferIdWithOrig (OccurrenceOf n) (nameRdrName n) n
tcInferRecSelId :: FieldOcc Name -> TcM (HsExpr TcId, TcRhoType) tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
tcInferRecSelId (FieldOcc lbl sel) = tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl sel tcInferRecSelId (Unambiguous lbl sel)
= tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl sel
tcInferRecSelId (Ambiguous lbl _)
= ambiguousSelector lbl
------------------------ ------------------------
tcInferIdWithOrig :: CtOrigin -> RdrName -> Name -> tcInferIdWithOrig :: CtOrigin -> RdrName -> Name ->
...@@ -1407,15 +1425,15 @@ getFixedTyVars upd_fld_occs univ_tvs cons ...@@ -1407,15 +1425,15 @@ getFixedTyVars upd_fld_occs univ_tvs cons
, tv `elemVarSet` fixed_tvs ] , tv `elemVarSet` fixed_tvs ]
{- {-
Note [Disambiguating record updates] Note [Disambiguating record fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the -XDuplicateRecordFields extension is used, and the renamer When the -XDuplicateRecordFields extension is used, and the renamer
encounters a record update that it cannot immediately disambiguate encounters a record selector or update that it cannot immediately
(because it involves fields that belong to multiple datatypes), it disambiguate (because it involves fields that belong to multiple
will defer resolution of the ambiguity to the typechecker. In this datatypes), it will defer resolution of the ambiguity to the
case, the `hsRecUpdFieldSel` field of the `HsRecUpdField` stores a typechecker. In this case, the `Ambiguous` constructor of
list of candidate selectors. `AmbiguousFieldOcc` is used.
Consider the following definitions: Consider the following definitions:
...@@ -1423,9 +1441,31 @@ Consider the following definitions: ...@@ -1423,9 +1441,31 @@ Consider the following definitions:
data T = MkT { foo :: Int, bar :: Int } data T = MkT { foo :: Int, bar :: Int }
data U = MkU { bar :: Int, baz :: Int } data U = MkU { bar :: Int, baz :: Int }
When the renamer sees an update of `foo`, it will not know which When the renamer sees `foo` as a selector or an update, it will not
parent datatype is in use. The `disambiguateRecordBinds` function know which parent datatype is in use.
tries to determine the parent in three ways:
For selectors, there are two possible ways to disambiguate:
1. Check if the pushed-in type is a function whose domain is a
datatype, for example:
f s = (foo :: S -> Int) s
g :: T -> Int
g = foo
This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.
2. Check if the selector is applied to an argument that has a type
signature, for example:
h = foo (s :: S)
This is checked by `tcApp`.
Updates are slightly more complex. The `disambiguateRecordBinds`
function tries to determine the parent datatype in three ways:
1. Check for types that have all the fields being updated. For example: 1. Check for types that have all the fields being updated. For example:
...@@ -1450,10 +1490,13 @@ tries to determine the parent in three ways: ...@@ -1450,10 +1490,13 @@ tries to determine the parent in three ways:
h x = (x :: T) { foo = 3 } h x = (x :: T) { foo = 3 }
Note that we do not look up the types of variables being updated, and Note that we do not look up the types of variables being updated, and
no constraint-solving is performed, so for example the following will no constraint-solving is performed, so for example the following will
be rejected as ambiguous: be rejected as ambiguous:
let bad (s :: S) = foo s
let r :: T let r :: T
r = blah r = blah
in r { foo = 3 } in r { foo = 3 }
...@@ -1462,107 +1505,162 @@ be rejected as ambiguous: ...@@ -1462,107 +1505,162 @@ be rejected as ambiguous:
We could add further tests, of a more heuristic nature. For example, We could add further tests, of a more heuristic nature. For example,
rather than looking for an explicit signature, we could try to infer rather than looking for an explicit signature, we could try to infer
the type of the record expression, in case we are lucky enough to get the type of the argument to a selector or the record expression being
a TyConApp straight away. However, it might be hard for programmers to updated, in case we are lucky enough to get a TyConApp straight
predict whether a particular update is sufficiently obvious for the away. However, it might be hard for programmers to predict whether a
signature to be omitted. particular update is sufficiently obvious for the signature to be
omitted. Moreover, this might change the behaviour of typechecker in
non-obvious ways.
See also Note [HsRecField and HsRecUpdField] in HsPat.
-} -}
-- Given a RdrName that refers to multiple record fields, and the type
-- of its argument, try to determine the name of the selector that is
-- meant.
disambiguateSelector :: RdrName -> Type -> RnM Name
disambiguateSelector rdr parent_type
= do { fam_inst_envs <- tcGetFamInstEnvs
; case tyConOf fam_inst_envs parent_type of
Nothing -> ambiguousSelector rdr
Just p ->
do { xs <- lookupParents rdr
; let parent = RecSelData p
; case lookup parent xs of
Just gre -> do { addUsedGRE True gre
; return (gre_name gre) }
Nothing -> failWithTc (fieldNotInType parent rdr) } }
-- This field name really is ambiguous, so add a suitable "ambiguous
-- occurrence" error, then give up.
ambiguousSelector :: RdrName -> RnM a
ambiguousSelector rdr
= do { env <- getGlobalRdrEnv
; let gres = lookupGRE_RdrName rdr env
; setErrCtxt [] $ addNameClashErrRn rdr gres
; failM }
-- Disambiguate the fields in a record update.
-- See Note [Disambiguating record fields]
disambiguateRecordBinds :: LHsExpr Name -> [LHsRecUpdField Name] -> Type disambiguateRecordBinds :: LHsExpr Name -> [LHsRecUpdField Name] -> Type
-> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
disambiguateRecordBinds record_expr rbnds res_ty disambiguateRecordBinds record_expr rbnds res_ty
-- Are all the fields unambiguous?
= case mapM isUnambiguous rbnds of = case mapM isUnambiguous rbnds of
-- If so, just skip to looking up the Ids
-- Always the case if DuplicateRecordFields is off -- Always the case if DuplicateRecordFields is off
Just rbnds' -> lookupSelectors rbnds' Just rbnds' -> mapM lookupSelector rbnds'
Nothing -> do Nothing -> -- If not, try to identify a single parent
{ fam_inst_envs <- tcGetFamInstEnvs do { fam_inst_envs <- tcGetFamInstEnvs
; (rbnds_with_parents) <- fmap (zip rbnds) $ mapM getParents rbnds -- Look up the possible parents for each field
; (p :: RecSelParent) <- case possibleParents (map snd rbnds_with_parents) of ; rbnds_with_parents <- getUpdFieldsParents
[] -> failWithTc (noPossibleParents rbnds) ; let possible_parents = map (map fst . snd) rbnds_with_parents
[p] -> return p -- Identify a single parent
_ | Just p <- tyConOf fam_inst_envs res_ty -> return (RecSelData p) ; p <- identifyParent fam_inst_envs possible_parents
_ | Just sig_ty <- obviousSig (unLoc record_expr) -> -- Pick the right selector with that parent for each field
do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
; case tyConOf fam_inst_envs sig_tc_ty of
Just p -> return (RecSelData p)
Nothing -> failWithTc badOverloadedUpdate }
_ -> failWithTc badOverloadedUpdate
; assignParent p rbnds_with_parents }
where where
-- Extract the selector name of a field update if it is unambiguous
isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name) isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name)
isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
Unambiguous _ sel_name -> Just (x, sel_name) Unambiguous _ sel_name -> Just (x, sel_name)
Ambiguous{} -> Nothing Ambiguous{} -> Nothing
lookupSelectors :: [(LHsRecUpdField Name, Name)] -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -- Look up the possible parents and selector GREs for each field
lookupSelectors = mapM look getUpdFieldsParents :: TcM [(LHsRecUpdField Name
where , [(RecSelParent, GlobalRdrElt)])]
look :: (LHsRecUpdField Name, Name) -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)) getUpdFieldsParents
look (L l x, n) = do i <- tcLookupId n = fmap (zip rbnds) $ mapM
let L loc af = hsRecFieldLbl x (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
lbl = rdrNameAmbiguousFieldOcc af rbnds
return $ L l x { hsRecFieldLbl = L loc (Unambiguous lbl i) }
-- Given a the lists of possible parents for each field,
-- Extract the outermost TyCon of a type, if there is one; for -- identify a single parent
-- data families this is the representation tycon (because that's identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
-- where the fields live). identifyParent fam_inst_envs possible_parents
tyConOf fam_inst_envs ty = case tcSplitTyConApp_maybe ty of = case foldr1 intersect possible_parents of
Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) -- No parents for all fields: record update is ill-typed
Nothing -> Nothing [] -> failWithTc (noPossibleParents rbnds)
-- Exactly one datatype with all the fields: use that
-- Calculate the list of possible parent tycons, by taking the [p] -> return p
-- intersection of the possibilities for each field. -- Multiple possible parents: try harder to disambiguate
possibleParents :: [[(RecSelParent, a)]] -> [RecSelParent] -- Can we get a parent TyCon from the pushed-in type?
possibleParents = foldr1 intersect . map (map fst) _:_ | Just p <- tyConOf fam_inst_envs res_ty -> return (RecSelData p)
-- Does the expression being updated have a type signature?
-- Look up the parent tycon for each candidate record selector. -- If so, try to extract a parent TyCon from it
getParents :: LHsRecUpdField Name -> RnM [(RecSelParent, GlobalRdrElt)] | Just sig_ty <- obviousSig (unLoc record_expr)
getParents (L _ fld) = do -> do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
{ env <- getGlobalRdrEnv ; case tyConOf fam_inst_envs sig_tc_ty of
; let gres = lookupGRE_RdrName (unLoc (hsRecUpdFieldRdr fld)) env Just p -> return (RecSelData p)
; mapM lookupParent gres } Nothing -> failWithTc badOverloadedUpdate }
-- Nothing else we can try...
_ -> failWithTc badOverloadedUpdate
-- Make a field unambiguous by choosing the given parent.
-- Emits an error if the field cannot have that parent,
-- e.g. if the user writes
-- r { x = e } :: T
-- where T does not have field x.
pickParent :: RecSelParent
-> (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])
-> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
pickParent p (upd, xs)
= case lookup p xs of
-- Phew! The parent is valid for this field.
-- Previously ambiguous fields must be marked as
-- used now that we know which one is meant, but
-- unambiguous ones shouldn't be recorded again
-- (giving duplicate deprecation warnings).
Just gre -> do { unless (null (tail xs)) $ do
let L loc _ = hsRecFieldLbl (unLoc upd)
setSrcSpan loc $ addUsedGRE True gre
; lookupSelector (upd, gre_name gre) }
-- The field doesn't belong to this parent, so report
-- an error but keep going through all the fields
Nothing -> do { addErrTc (fieldNotInType p
(unLoc (hsRecUpdFieldRdr (unLoc upd))))
; lookupSelector (upd, gre_name (snd (head xs))) }
-- Given a (field update, selector name) pair, look up the
-- selector to give a field update with an unambiguous Id
lookupSelector :: (LHsRecUpdField Name, Name)
-> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
lookupSelector (L l upd, n)
= do { i <- tcLookupId n
; let L loc af = hsRecFieldLbl upd
lbl = rdrNameAmbiguousFieldOcc af
; return $ L l upd { hsRecFieldLbl = L loc (Unambiguous lbl i) } }
-- Extract the outermost TyCon of a type, if there is one; for
-- data families this is the representation tycon (because that's
-- where the fields live).
tyConOf :: FamInstEnvs -> Type -> Maybe TyCon
tyConOf fam_inst_envs ty = case tcSplitTyConApp_maybe ty of
Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
Nothing -> Nothing
-- For an ambiguous record field, find all the candidate record
-- selectors (as GlobalRdrElts) and their parents.
lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
lookupParents rdr
= do { env <- getGlobalRdrEnv
; let gres = lookupGRE_RdrName rdr env
; mapM lookupParent gres }
where
lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
lookupParent gre = do { id <- tcLookupId (gre_name gre) lookupParent gre = do { id <- tcLookupId (gre_name gre)
; ASSERT(isRecordSelector id) ; if isRecordSelector id
return (recordSelectorTyCon id, gre) } then return (recordSelectorTyCon id, gre)
else failWithTc (notSelector (gre_name gre)) }
-- Make all the fields unambiguous by choosing the given parent.