diff options
Diffstat (limited to 'compiler/GHC/Tc/TyCl/PatSyn.hs')
| -rw-r--r-- | compiler/GHC/Tc/TyCl/PatSyn.hs | 92 |
1 files changed, 47 insertions, 45 deletions
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 2fd0669f91..d9f9be2afc 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -103,13 +103,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -699,17 +698,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 @@ -717,7 +716,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 @@ -744,7 +743,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) @@ -821,7 +820,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 @@ -843,15 +842,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 @@ -864,44 +862,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) @@ -909,10 +910,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 } } } @@ -924,7 +927,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) @@ -932,7 +935,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)) @@ -951,13 +954,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) |