diff options
Diffstat (limited to 'compiler/GHC/Tc/Utils/Zonk.hs')
| -rw-r--r-- | compiler/GHC/Tc/Utils/Zonk.hs | 45 |
1 files changed, 32 insertions, 13 deletions
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index b798593c1d..ba29d0e3c8 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -29,7 +29,7 @@ module GHC.Tc.Utils.Zonk ( zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkTopBndrs, ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, - zonkTyVarBindersX, zonkTyVarBinderX, + zonkTyVarBindersX, zonkTyVarBinderX, zonkTyCoBinderX, zonkTyCoBindersX, zonkTyBndrs, zonkTyBndrsX, zonkTcTypeToType, zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, @@ -63,6 +63,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.ConLike import GHC.Core.DataCon +import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import GHC.Utils.Outputable import GHC.Utils.Misc @@ -460,6 +461,17 @@ zonkTyVarBinderX env (Bndr tv vis) = do { (env', tv') <- zonkTyBndrX env tv ; return (env', Bndr tv' vis) } +zonkTyCoBinderX :: ZonkEnv -> TyCoBinder -> TcM TyCoBinder +zonkTyCoBinderX env (Anon flag ty) = + do { ty' <- zonkScaledTcTypeToTypeX env ty + ; return $ Anon flag ty' } +zonkTyCoBinderX env (Named tv) = + do { (_, tv') <- zonkTyVarBinderX env tv + ; return $ Named tv' } + +zonkTyCoBindersX :: ZonkEnv -> [TyCoBinder] -> TcM [TyCoBinder] +zonkTyCoBindersX env bndrs = mapM (zonkTyCoBinderX env) bndrs + zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc) zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e @@ -677,7 +689,7 @@ zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys res_ty origin }) = do { ms' <- mapM (zonkMatch env zBody) ms - ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys + ; arg_tys' <- zonkTyCoBindersX env arg_tys ; res_ty' <- zonkTcTypeToTypeX env res_ty ; return (MG { mg_alts = L l ms' , mg_ext = MatchGroupTc arg_tys' res_ty' origin @@ -690,7 +702,7 @@ zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) zonkMatch env zBody (L loc match@(Match { m_pats = pats , m_grhss = grhss })) - = do { (env1, new_pats) <- zonkMatchPats env pats + = do { (env1, new_pats) <- zonkLMatchPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } @@ -1296,6 +1308,18 @@ zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc) -- to the right) zonkPat env pat = wrapLocSndMA (zonk_pat env) pat +zonkLMatchPat :: ZonkEnv -> LMatchPat GhcTc -> TcM (ZonkEnv, LMatchPat GhcTc) +zonkLMatchPat env (L l (VisPat x pat)) + = do { (env', p') <- zonkPat env pat + ; return (env', L l (VisPat x p')) + } +zonkLMatchPat env (L l (InvisTyVarPat t (L l' (UserTyVar x () (L l'' idp))))) + = do { (env', (L _ idp')) <- wrapLocSndM (zonkTyBndrX env) (L noSrcSpan idp) + ; let zonkedNewTyVar = L l' (UserTyVar x () (L l'' idp')) + ; return (env', L l (InvisTyVarPat t zonkedNewTyVar)) + } +zonkLMatchPat env p = return (env, p) + zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc) zonk_pat env (ParPat x lpar p rpar) = do { (env', p') <- zonkPat env p @@ -1442,16 +1466,11 @@ zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat ; (env', pats') <- zonkPats env1 pats ; return (env', pat':pats') } -zonkMatchPats :: ZonkEnv -> [LMatchPat GhcTc] -> TcM (ZonkEnv, [LMatchPat GhcTc]) -zonkMatchPats env [] = return (env, []) -zonkMatchPats env (pat:pats) = - case pat of - L l (VisPat x lpat) -> do { (env1, pat') <- zonkPat env lpat - ; (env', pats') <- zonkMatchPats env1 pats - ; return (env', L l (VisPat x pat') : pats') - } - L _ (InvisTyVarPat x _) -> dataConCantHappen x - L _ (InvisWildTyPat x) -> dataConCantHappen x +zonkLMatchPats :: ZonkEnv -> [LMatchPat GhcTc] -> TcM (ZonkEnv, [LMatchPat GhcTc]) +zonkLMatchPats env [] = return (env, []) +zonkLMatchPats env (pat:pats) = do { (env1, pat') <- zonkLMatchPat env pat + ; (env', pats') <- zonkLMatchPats env1 pats + ; return (env', pat' : pats') } {- ************************************************************************ |