diff options
Diffstat (limited to 'compiler/GHC/Tc')
| -rw-r--r-- | compiler/GHC/Tc/Gen/Bind.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Expr.hs | 21 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Head.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Build.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl/PatSyn.hs | 92 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl/PatSyn.hs-boot | 3 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Zonk.hs | 6 |
7 files changed, 69 insertions, 71 deletions
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index b61d265583..62c6cb218a 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -320,7 +320,7 @@ tcValBinds top_lvl binds sigs thing_inside do { thing <- thing_inside -- See Note [Pattern synonym builders don't yield dependencies] -- in GHC.Rename.Bind - ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns + ; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ] ; return (extra_binds, thing) } diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 4f0fc23af3..2d5a49f2e6 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -569,7 +569,7 @@ tcExpr (HsStatic fvs expr) res_ty ************************************************************************ -} -tcExpr expr@(RecordCon { rcon_con_name = L loc con_name +tcExpr expr@(RecordCon { rcon_con = L loc con_name , rcon_flds = rbinds }) res_ty = do { con_like <- tcLookupConLike con_name @@ -580,22 +580,19 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name ; let arity = conLikeArity con_like Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau - ; case conLikeWrapId_maybe con_like of { - Nothing -> nonBidirectionalErr (conLikeName con_like) ; - Just con_id -> + ; checkTc (conLikeHasBuilder con_like) $ + nonBidirectionalErr (conLikeName con_like) - do { rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds + ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds -- It is currently not possible for a record to have -- multiplicities. When they do, `tcRecordBinds` will take -- scaled types instead. Meanwhile, it's safe to take -- `scaledThing` above, as we know all the multiplicities are -- Many. - ; let rcon_tc = RecordConTc - { rcon_con_like = con_like - , rcon_con_expr = mkHsWrap con_wrap con_expr } + ; let rcon_tc = mkHsWrap con_wrap con_expr expr' = RecordCon { rcon_ext = rcon_tc - , rcon_con_name = L loc con_id + , rcon_con = L loc con_like , rcon_flds = rbinds' } ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty @@ -610,7 +607,7 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name -- via a new `HoleSort`. But that seems too much work. ; checkMissingFields con_like rbinds arg_tys - ; return ret } } } + ; return ret } where orig = OccurrenceOf con_name @@ -837,8 +834,8 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- Check that we're not dealing with a unidirectional pattern -- synonym - ; unless (isJust $ conLikeWrapId_maybe con1) - (nonBidirectionalErr (conLikeName con1)) + ; checkTc (conLikeHasBuilder con1) $ + nonBidirectionalErr (conLikeName con1) -- STEP 3 Note [Criteria for update] -- Check that each updated field is polymorphic; that is, its type diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 84e391ee50..fa642131c1 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -773,7 +773,7 @@ tc_infer_id id_name | Just (expr, ty) <- patSynBuilderOcc ps -> return (expr, ty) | otherwise - -> nonBidirectionalErr id_name + -> failWithTc (nonBidirectionalErr id_name) AGlobal (ATyCon ty_con) -> fail_tycon global_env ty_con @@ -855,10 +855,9 @@ check_naughty lbl id | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) | otherwise = return () -nonBidirectionalErr :: Outputable name => name -> TcM a -nonBidirectionalErr name = failWithTc $ - text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" +nonBidirectionalErr :: Outputable name => name -> SDoc +nonBidirectionalErr name = text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" {- Note [Linear fields generalization] diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs index 52a5592d67..588f209377 100644 --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -33,7 +33,6 @@ import GHC.Types.Id.Make import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Type -import GHC.Types.Id import GHC.Types.SourceText import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity @@ -171,7 +170,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs ------------------------------------------------------ buildPatSyn :: Name -> Bool - -> (Id,Bool) -> Maybe (Id, Bool) + -> PatSynMatcher -> PatSynBuilder -> ([InvisTVBinder], ThetaType) -- ^ Univ and req -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov -> [Type] -- ^ Argument types @@ -179,7 +178,7 @@ buildPatSyn :: Name -> Bool -> [FieldLabel] -- ^ Field labels for -- a record pattern synonym -> PatSyn -buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder +buildPatSyn src_name declared_infix matcher@(_, matcher_ty,_) builder (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty field_labels = -- The assertion checks that the matcher is @@ -202,7 +201,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder arg_tys pat_ty matcher builder field_labels where - ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id + ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ matcher_ty ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy (scaledThing cont_sigma) (arg_tys1, _) = (tcSplitFunTys cont_tau) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 593226db5c..43388472d7 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -104,13 +104,12 @@ recoverPSB (PSB { psb_id = L _ name ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], []) [] -- Arg tys alphaTy - (matcher_id, True) Nothing + (matcher_name, matcher_ty, True) Nothing [] -- Field labels where -- The matcher_id is used only by the desugarer, so actually -- and error-thunk would probably do just as well here. - matcher_id = mkLocalId matcher_name Many $ - mkSpecForAllTys [alphaTyVar] alphaTy + matcher_ty = mkSpecForAllTys [alphaTyVar] alphaTy {- Note [Pattern synonym error recovery] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -700,17 +699,17 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn ppr pat_ty -- Make the 'matcher' - ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn + ; (matcher, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty -- Make the 'builder' - ; builder_id <- mkPatSynBuilderId dir lname - univ_tvs req_theta - ex_tvs prov_theta - arg_tys pat_ty prag_fn + ; builder <- mkPatSynBuilder dir lname + univ_tvs req_theta + ex_tvs prov_theta + arg_tys pat_ty -- Make the PatSyn itself ; let patSyn = mkPatSyn (unLoc lname) is_infix @@ -718,7 +717,7 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn (ex_tvs, prov_theta) arg_tys pat_ty - matcher_id builder_id + matcher builder field_labels -- Selectors @@ -745,7 +744,7 @@ tcPatSynMatcher :: Located Name -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) -> ([LHsExpr GhcTc], [TcType]) -> TcType - -> TcM ((Id, Bool), LHsBinds GhcTc) + -> TcM (PatSynMatcher, LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn tcPatSynMatcher (L loc name) lpat prag_fn (univ_tvs, req_theta, req_ev_binds, req_dicts) @@ -823,7 +822,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) ; traceTc "tcPatSynMatcher" (ppr matcher_bind) - ; return ((matcher_prag_id, is_unlifted), matcher_bind) } + ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) } mkPatSynRecSelBinds :: PatSyn -> [FieldLabel] -- ^ Visible field labels @@ -845,15 +844,14 @@ isUnidirectional ExplicitBidirectional{} = False ************************************************************************ -} -mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [InvisTVBinder] -> ThetaType - -> [InvisTVBinder] -> ThetaType - -> [Type] -> Type - -> TcPragEnv - -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (L _ name) +mkPatSynBuilder :: HsPatSynDir a -> Located Name + -> [InvisTVBinder] -> ThetaType + -> [InvisTVBinder] -> ThetaType + -> [Type] -> Type + -> TcM PatSynBuilder +mkPatSynBuilder dir (L _ name) univ_bndrs req_theta ex_bndrs prov_theta - arg_tys pat_ty prag_fn + arg_tys pat_ty | isUnidirectional dir = return Nothing | otherwise @@ -866,44 +864,47 @@ mkPatSynBuilderId dir (L _ name) mkPhiTy theta $ mkVisFunTysMany arg_tys $ pat_ty - builder_id = mkExportedVanillaId builder_name builder_sigma - -- See Note [Exported LocalIds] in GHC.Types.Id - - builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id - prags = lookupPragEnv prag_fn name - -- See Note [Pragmas for pattern synonyms] - - ; builder_prag_id <- addInlinePrags builder_id' prags - ; return (Just (builder_prag_id, need_dummy_arg)) } + ; return (Just (builder_name, builder_sigma, need_dummy_arg)) } -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn +tcPatSynBuilderBind :: TcPragEnv + -> PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -tcPatSynBuilderBind (PSB { psb_id = L loc name - , psb_def = lpat - , psb_dir = dir - , psb_args = details }) +tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) + , psb_def = lpat + , psb_dir = dir + , psb_args = details }) | isUnidirectional dir = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern = setSrcSpan (getLoc lpat) $ failWithTc $ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" - <+> quotes (ppr name) <> colon) + <+> quotes (ppr ps_name) <> colon) 2 why , text "RHS pattern:" <+> ppr lpat ] | Right match_group <- mb_match_group -- Bidirectional - = do { patsyn <- tcLookupPatSyn name + = do { patsyn <- tcLookupPatSyn ps_name ; case patSynBuilder patsyn of { Nothing -> return emptyBag ; -- This case happens if we found a type error in the -- pattern synonym, recovered, and put a placeholder -- with patSynBuilder=Nothing in the environment - Just (builder_id, need_dummy_arg) -> -- Normal case + Just (builder_name, builder_ty, need_dummy_arg) -> -- Normal case do { -- Bidirectional, so patSynBuilder returns Just - let match_group' | need_dummy_arg = add_dummy_arg match_group + let pat_ty = patSynResultType patsyn + builder_id = modifyIdInfo (`setLevityInfoWithType` pat_ty) $ + mkExportedVanillaId builder_name builder_ty + -- See Note [Exported LocalIds] in GHC.Types.Id + prags = lookupPragEnv prag_fn ps_name + -- See Note [Pragmas for pattern synonyms] + -- Keyed by the PatSyn Name, not the (internal) builder name + + ; builder_id <- addInlinePrags builder_id prags + + ; let match_group' | need_dummy_arg = add_dummy_arg match_group | otherwise = match_group bind = FunBind { fun_id = L loc (idName builder_id) @@ -911,10 +912,12 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name , fun_ext = emptyNameSet , fun_tick = [] } - sig = completeSigFromId (PatSynCtxt name) builder_id + sig = completeSigFromId (PatSynCtxt ps_name) builder_id ; traceTc "tcPatSynBuilderBind {" $ - ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id) + vcat [ ppr patsyn + , ppr builder_id <+> dcolon <+> ppr (idType builder_id) + , ppr prags ] ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds ; return builder_binds } } } @@ -926,7 +929,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name mb_match_group = case dir of ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat) + ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat) Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) @@ -934,7 +937,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name where builder_args = [L loc (VarPat noExtField (L loc n)) | L loc n <- args] - builder_match = mkMatch (mkPrefixFunRhs (L loc name)) + builder_match = mkMatch (mkPrefixFunRhs ps_lname) builder_args body (noLoc (EmptyLocalBinds noExtField)) @@ -953,13 +956,12 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType) patSynBuilderOcc ps - | Just (builder_id, add_void_arg) <- patSynBuilder ps + | Just (_, builder_ty, add_void_arg) <- patSynBuilder ps , let builder_expr = HsConLikeOut noExtField (PatSynCon ps) - builder_ty = idType builder_id = Just $ if add_void_arg - then ( builder_expr -- still just return builder_expr; the void# arg is added - -- by dsConLike in the desugarer + then ( builder_expr -- still just return builder_expr; the void# arg + -- is added by dsConLike in the desugarer , tcFunResultTy builder_ty ) else (builder_expr, builder_ty) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot index 22e5c9fb86..844a4c394d 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot @@ -12,5 +12,6 @@ tcPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv) -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) +tcPatSynBuilderBind :: TcPragEnv -> PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc) diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 5bd1fe490d..76b101c679 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -889,10 +889,10 @@ zonkExpr env (ExplicitList ty wit exprs) where zonkWit env Nothing = return (env, Nothing) zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln -zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) +zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) + = do { new_con_expr <- zonkExpr env con_expr ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } + ; return (expr { rcon_ext = new_con_expr , rcon_flds = new_rbinds }) } zonkExpr env (RecordUpd { rupd_flds = rbinds |