diff options
Diffstat (limited to 'compiler/GHC/Tc/TyCl/PatSyn.hs')
| -rw-r--r-- | compiler/GHC/Tc/TyCl/PatSyn.hs | 73 |
1 files changed, 38 insertions, 35 deletions
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 69a0d2898c..642429d61b 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -638,9 +638,9 @@ collectPatSynArgInfo details = InfixCon name1 name2 -> (map unLoc [name1, name2], True) RecCon names -> (map (unLoc . recordPatSynPatVar) names, False) -addPatSynCtxt :: Located Name -> TcM a -> TcM a +addPatSynCtxt :: LocatedN Name -> TcM a -> TcM a addPatSynCtxt (L loc name) thing_inside - = setSrcSpan loc $ + = setSrcSpanA loc $ addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $ thing_inside @@ -654,7 +654,7 @@ wrongNumberOfParmsErr name decl_arity missing ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn -tc_patsyn_finish :: Located Name -- ^ PatSyn Name +tc_patsyn_finish :: LocatedN Name -- ^ PatSyn Name -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) -> Bool -- ^ Whether infix -> LPat GhcTc -- ^ Pattern of the PatSyn @@ -737,7 +737,7 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn ************************************************************************ -} -tcPatSynMatcher :: Located Name +tcPatSynMatcher :: LocatedN Name -> LPat GhcTc -> TcPragEnv -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) @@ -750,8 +750,9 @@ tcPatSynMatcher (L loc name) lpat prag_fn (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty - = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc - ; tv_name <- newNameAt (mkTyVarOcc "r") loc + = do { let loc' = locA loc + ; rr_name <- newNameAt (mkTyVarOcc "rep") loc' + ; tv_name <- newNameAt (mkTyVarOcc "r") loc' ; let rr_tv = mkTyVar rr_name runtimeRepTy rr = mkTyVarTy rr_tv res_tv = mkTyVar tv_name (tYPE rr) @@ -782,7 +783,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn fail' = nlHsApps fail [nlHsVar voidPrimId] args = map nlVarPat [scrutinee, cont, fail] - lwpat = noLoc $ WildPat pat_ty + lwpat = noLocA $ WildPat pat_ty cases = if isIrrefutableHsPat dflags lpat then [mkHsCaseAlt lpat cont'] else [mkHsCaseAlt lpat cont', @@ -790,23 +791,23 @@ tcPatSynMatcher (L loc name) lpat prag_fn body = mkLHsWrap (mkWpLet req_ev_binds) $ L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ - MG{ mg_alts = L (getLoc lpat) cases + MG{ mg_alts = L (l2l $ getLoc lpat) cases , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty , mg_origin = Generated } - body' = noLoc $ + body' = noLocA $ HsLam noExtField $ - MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr - args body] + MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr + args body] , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty , mg_origin = Generated } match = mkMatch (mkPrefixFunRhs (L loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') - (noLoc (EmptyLocalBinds noExtField)) + (EmptyLocalBinds noExtField) mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = L (getLoc match) [match] + mg = MG{ mg_alts = L (l2l $ getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } @@ -818,7 +819,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn , fun_matches = mg , fun_ext = idHsWrapper , fun_tick = [] } - matcher_bind = unitBag (noLoc bind) + matcher_bind = unitBag (noLocA bind) ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) ; traceTc "tcPatSynMatcher" (ppr matcher_bind) @@ -845,7 +846,7 @@ isUnidirectional ExplicitBidirectional{} = False ************************************************************************ -} -mkPatSynBuilder :: HsPatSynDir a -> Located Name +mkPatSynBuilder :: HsPatSynDir a -> LocatedN Name -> [InvisTVBinder] -> ThetaType -> [InvisTVBinder] -> ThetaType -> [Type] -> Type @@ -879,7 +880,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLoc lpat) $ failWithTc $ + = setSrcSpan (getLocA lpat) $ failWithTc $ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" <+> quotes (ppr ps_name) <> colon) 2 why @@ -919,7 +920,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) vcat [ ppr patsyn , ppr builder_id <+> dcolon <+> ppr (idType builder_id) , ppr prags ] - ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) + ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds ; return builder_binds } } } @@ -934,13 +935,13 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) - mk_mg body = mkMatchGroup Generated [builder_match] + mk_mg body = mkMatchGroup Generated (noLocA [builder_match]) where - builder_args = [L loc (VarPat noExtField (L loc n)) + builder_args = [L (na2la loc) (VarPat noExtField (L loc n)) | L loc n <- args] builder_match = mkMatch (mkPrefixFunRhs ps_lname) builder_args body - (noLoc (EmptyLocalBinds noExtField)) + (EmptyLocalBinds noExtField) args = case details of PrefixCon _ args -> args @@ -974,7 +975,7 @@ add_void need_dummy_arg ty | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty | otherwise = ty -tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn +tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), @@ -989,19 +990,22 @@ tcPatToExpr name args pat = go pat lhsVars = mkNameSet (map unLoc args) -- Make a prefix con for prefix and infix patterns for simplicity - mkPrefixConExpr :: Located Name -> [LPat GhcRn] + mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats - ; let con = L loc (HsVar noExtField lcon) + ; let con = L (l2l loc) (HsVar noExtField lcon) ; return (unLoc $ mkHsApps con exprs) } - mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) + mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn) -> Either SDoc (HsExpr GhcRn) - mkRecordConExpr con fields - = do { exprFields <- mapM go fields - ; return (RecordCon noExtField con exprFields) } + mkRecordConExpr con (HsRecFields fields dd) + = do { exprFields <- mapM go' fields + ; return (RecordCon noExtField con (HsRecFields exprFields dd)) } + + go' :: LHsRecField GhcRn (LPat GhcRn) -> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn)) + go' (L l rf) = L l <$> traverse go rf go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p @@ -1021,25 +1025,24 @@ tcPatToExpr name args pat = go pat = return $ HsVar noExtField (L l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") - go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat + go1 (ParPat _ pat) = fmap (HsPar noAnn) $ go pat go1 p@(ListPat reb pats) | Nothing <- reb = do { exprs <- mapM go pats ; return $ ExplicitList noExtField exprs } | otherwise = notInvertibleListPat p go1 (TuplePat _ pats box) = do { exprs <- mapM go pats ; return $ ExplicitTuple noExtField - (map (noLoc . (Present noExtField)) exprs) - box } + (map (Present noAnn) exprs) box } go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) ; return $ ExplicitSum noExtField alt arity - (noLoc expr) + (noLocA expr) } - go1 (LitPat _ lit) = return $ HsLit noExtField lit + go1 (LitPat _ lit) = return $ HsLit noComments lit go1 (NPat _ (L _ n) mb_neg _) | Just (SyntaxExprRn neg) <- mb_neg - = return $ unLoc $ foldl' nlHsApp (noLoc neg) - [noLoc (HsOverLit noExtField n)] - | otherwise = return $ HsOverLit noExtField n + = return $ unLoc $ foldl' nlHsApp (noLocA neg) + [noLocA (HsOverLit noAnn n)] + | otherwise = return $ HsOverLit noAnn n go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go1 pat go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" |