diff options
Diffstat (limited to 'compiler/typecheck/TcPatSyn.hs')
| -rw-r--r-- | compiler/typecheck/TcPatSyn.hs | 62 |
1 files changed, 35 insertions, 27 deletions
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 5fad219a90..eefdb97f16 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -8,6 +8,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind , tcPatSynBuilderOcc, nonBidirectionalErr @@ -79,7 +80,8 @@ tcPatSynDecl psb mb_sig recoverPSB :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -- See Note [Pattern synonym error recovery] -recoverPSB (PSB { psb_id = L _ name, psb_args = details }) +recoverPSB (PSB { psb_id = (dL->L _ name) + , psb_args = details }) = do { matcher_name <- newImplicitBinder name mkMatcherOcc ; let placeholder = AConLike $ PatSynCon $ mk_placeholder matcher_name @@ -132,7 +134,7 @@ pattern.) But it'll do for now. tcInferPatSynDecl :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details +tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details , psb_def = lpat, psb_dir = dir }) = addPatSynCtxt lname $ do { traceTc "tcInferPatSynDecl {" $ ppr name @@ -302,7 +304,7 @@ is not very helpful, but at least we don't get a Lint error. tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPatSynInfo -> TcM (LHsBinds GhcTc, TcGblEnv) -tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details +tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } TPSI{ patsig_implicit_bndrs = implicit_tvs , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta @@ -580,12 +582,13 @@ collectPatSynArgInfo details = where splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name) - splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar - , recordPatSynSelectorId = L _ selId }) + splitRecordPatSyn (RecordPatSynField + { recordPatSynPatVar = (dL->L _ patVar) + , recordPatSynSelectorId = (dL->L _ selId) }) = (patVar, selId) addPatSynCtxt :: Located Name -> TcM a -> TcM a -addPatSynCtxt (L loc name) thing_inside +addPatSynCtxt (dL->L loc name) thing_inside = setSrcSpan loc $ addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $ @@ -696,7 +699,7 @@ tcPatSynMatcher :: Located Name -> TcType -> TcM ((Id, Bool), LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynMatcher (L loc name) lpat +tcPatSynMatcher (dL->L loc name) lpat (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty @@ -737,9 +740,9 @@ tcPatSynMatcher (L loc name) lpat else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] body = mkLHsWrap (mkWpLet req_ev_binds) $ - L (getLoc lpat) $ + cL (getLoc lpat) $ HsCase noExt (nlHsVar scrutinee) $ - MG{ mg_alts = L (getLoc lpat) cases + MG{ mg_alts = cL (getLoc lpat) cases , mg_ext = MatchGroupTc [pat_ty] res_ty , mg_origin = Generated } @@ -750,18 +753,18 @@ tcPatSynMatcher (L loc name) lpat , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty , mg_origin = Generated } - match = mkMatch (mkPrefixFunRhs (L loc name)) [] + match = mkMatch (mkPrefixFunRhs (cL loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (noLoc (EmptyLocalBinds noExt)) mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = L (getLoc match) [match] + mg = MG{ mg_alts = cL (getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } ; let bind = FunBind{ fun_ext = emptyNameSet - , fun_id = L loc matcher_id + , fun_id = cL loc matcher_id , fun_matches = mg , fun_co_fn = idHsWrapper , fun_tick = [] } @@ -797,7 +800,7 @@ mkPatSynBuilderId :: HsPatSynDir a -> Located Name -> [TyVarBinder] -> ThetaType -> [Type] -> Type -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (L _ name) +mkPatSynBuilderId dir (dL->L _ name) univ_bndrs req_theta ex_bndrs prov_theta arg_tys pat_ty | isUnidirectional dir @@ -823,8 +826,10 @@ mkPatSynBuilderId dir (L _ name) tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat - , psb_dir = dir, psb_args = details }) +tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) + , psb_def = lpat + , psb_dir = dir + , psb_args = details }) | isUnidirectional dir = return emptyBag @@ -849,7 +854,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat | otherwise = match_group bind = FunBind { fun_ext = placeHolderNamesTc - , fun_id = L loc (idName builder_id) + , fun_id = cL loc (idName builder_id) , fun_matches = match_group' , fun_co_fn = idHsWrapper , fun_tick = [] } @@ -873,8 +878,9 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) mk_mg body = mkMatchGroup Generated [builder_match] where - builder_args = [L loc (VarPat noExt (L loc n)) | L loc n <- args] - builder_match = mkMatch (mkPrefixFunRhs (L loc name)) + builder_args = [cL loc (VarPat noExt (cL loc n)) + | (dL->L loc n) <- args] + builder_match = mkMatch (mkPrefixFunRhs (cL loc name)) builder_args body (noLoc (EmptyLocalBinds noExt)) @@ -885,8 +891,10 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) -> MatchGroup GhcRn (LHsExpr GhcRn) - add_dummy_arg mg@(MG { mg_alts = L l [L loc match@(Match { m_pats = pats })] }) - = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } + add_dummy_arg mg@(MG { mg_alts = + (dL->L l [dL->L loc + match@(Match { m_pats = pats })]) }) + = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind" @@ -932,9 +940,9 @@ tcPatToExpr name args pat = go pat -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: Located Name -> [LPat GhcRn] -> Either MsgDoc (HsExpr GhcRn) - mkPrefixConExpr lcon@(L loc _) pats + mkPrefixConExpr lcon@(dL->L loc _) pats = do { exprs <- mapM go pats - ; return (foldl' (\x y -> HsApp noExt (L loc x) y) + ; return (foldl' (\x y -> HsApp noExt (cL loc x) y) (HsVar noExt lcon) exprs) } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) @@ -944,7 +952,7 @@ tcPatToExpr name args pat = go pat ; return (RecordCon noExt con exprFields) } go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) - go (L loc p) = L loc <$> go1 p + go (dL->L loc p) = cL loc <$> go1 p go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) go1 (ConPatIn con info) @@ -956,9 +964,9 @@ tcPatToExpr name args pat = go pat go1 (SigPat _ pat _) = go1 (unLoc pat) -- See Note [Type signatures and the builder expression] - go1 (VarPat _ (L l var)) + go1 (VarPat _ (dL->L l var)) | var `elemNameSet` lhsVars - = return $ HsVar noExt (L l var) + = return $ HsVar noExt (cL l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") go1 (ParPat _ pat) = fmap (HsPar noExt) $ go pat @@ -975,7 +983,7 @@ tcPatToExpr name args pat = go pat (noLoc expr) } go1 (LitPat _ lit) = return $ HsLit noExt lit - go1 (NPat _ (L _ n) mb_neg _) + go1 (NPat _ (dL->L _ n) mb_neg _) | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit noExt n)] | otherwise = return $ HsOverLit noExt n @@ -1147,7 +1155,7 @@ tcCollectEx pat = go pat = mergeMany . map goRecFd $ flds goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) - goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p + goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) mergeMany = foldr merge empty |