[commit: ghc] wip/14691: Checkpoint zonkCoreExpr (0b20598)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/14691
Link       : http://ghc.haskell.org/trac/ghc/changeset/0b2059823daf33bd656c3e0618daef260ecbedea/ghc

>---------------------------------------------------------------

commit 0b2059823daf33bd656c3e0618daef260ecbedea
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sat Jan 20 14:03:22 2018 -0500

    Checkpoint zonkCoreExpr


>---------------------------------------------------------------

0b2059823daf33bd656c3e0618daef260ecbedea
 compiler/typecheck/TcHsSyn.hs | 57 ++++++++++++++++++++++++++++++++++++-------
 1 file changed, 48 insertions(+), 9 deletions(-)

diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index d56416c..e0d4bc0 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -71,6 +71,7 @@ import Bag
 import Outputable
 import Util
 import UniqFM
+import CoreSyn
 
 import Control.Monad
 import Data.List  ( partition )
@@ -952,7 +953,7 @@ zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
                               ; return (env, WpCast co') }
 zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
                                  ; return (env', WpEvLam ev') }
-zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
+zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkCoreExpr env arg
                                  ; return (env, WpEvApp arg') }
 zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
                               do { (env', tv') <- zonkTyBndrX env tv
@@ -1419,7 +1420,45 @@ zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
 ************************************************************************
 -}
 
-zonkEvTerm env et = error "zonkEvTerm"
+zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
+zonkCoreExpr env (Var v)
+    | isCoVar v
+    = Coercion <$> zonkCoVarOcc env v
+    | otherwise
+    = return (Var $ zonkIdOcc env v)
+zonkCoreExpr _ (Lit l)
+    = return $ Lit l
+zonkCoreExpr env (Coercion co)
+    = Coercion <$> zonkCoToCo env co
+zonkCoreExpr env (App e1 e2)
+    = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2
+zonkCoreExpr env (Lam v e)
+    = do v' <- zonkIdBndr env v
+         let env1 = extendIdZonkEnv1 env v'
+         Lam v' <$> zonkCoreExpr env1 e
+zonkCoreExpr env (Let bind e)
+    = do (env1, bind') <- zonkCoreBind env bind
+         Let bind'<$> zonkCoreExpr env1 e
+
+zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
+zonkCoreBind env (NonRec v e)
+    = do v' <- zonkIdBndr env v
+         e' <- zonkCoreExpr env e
+         let env1 = extendIdZonkEnv1 env v'
+         return (env1, NonRec v' e')
+zonkCoreBind env (Rec pairs)
+    = do (env1, pairs') <- fixM go
+         return (env1, Rec pairs')
+  where
+    go ~(_, new_pairs) = do
+         let env1 = extendIdZonkEnvRec env (map fst new_pairs)
+         pairs' <- mapM (zonkCorePair env1) pairs
+         return (env1, pairs')
+
+zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)
+zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e
+
+
 {-
 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
 zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v )
@@ -1459,18 +1498,18 @@ zonkEvTerm env (EvSelector sel_id tys tms)
 
 zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
 zonkEvTypeable env (EvTypeableTyCon tycon e)
-  = do { e'  <- mapM (zonkEvTerm env) e
+  = do { e'  <- mapM (zonkCoreExpr env) e
        ; return $ EvTypeableTyCon tycon e' }
 zonkEvTypeable env (EvTypeableTyApp t1 t2)
-  = do { t1' <- zonkEvTerm env t1
-       ; t2' <- zonkEvTerm env t2
+  = do { t1' <- zonkCoreExpr env t1
+       ; t2' <- zonkCoreExpr env t2
        ; return (EvTypeableTyApp t1' t2') }
 zonkEvTypeable env (EvTypeableTrFun t1 t2)
-  = do { t1' <- zonkEvTerm env t1
-       ; t2' <- zonkEvTerm env t2
+  = do { t1' <- zonkCoreExpr env t1
+       ; t2' <- zonkCoreExpr env t2
        ; return (EvTypeableTrFun t1' t2') }
 zonkEvTypeable env (EvTypeableTyLit t1)
-  = do { t1' <- zonkEvTerm env t1
+  = do { t1' <- zonkCoreExpr env t1
        ; return (EvTypeableTyLit t1') }
 
 zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
@@ -1513,7 +1552,7 @@ zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
        ; term' <- case getEqPredTys_maybe (idType var') of
            Just (r, ty1, ty2) | ty1 `eqType` ty2
                   -> return (evCoercion (mkTcReflCo r ty1))
-           _other -> zonkEvTerm env term
+           _other -> zonkCoreExpr env term
 
        ; return (bind { eb_lhs = var', eb_rhs = term' }) }