Propagate polytypes into if and case.
authorRichard Eisenberg <eir@cis.upenn.edu>
Fri, 10 Jul 2015 14:15:15 +0000 (10:15 -0400)
committerRichard Eisenberg <eir@cis.upenn.edu>
Fri, 10 Jul 2015 14:15:15 +0000 (10:15 -0400)
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcMatches.hs

index ca7cbc3..26ce358 100644 (file)
@@ -456,12 +456,10 @@ tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
   = do { pred' <- tcMonoExpr pred boolTy
             -- this forces the branches to be fully instantiated
             -- (See #10619)
-       ; tau_ty <- newFlexiTyVarTy openTypeKind
-       ; wrap   <- tcSubTypeHR tau_ty res_ty
-       ; tau_ty <- zonkTcType tau_ty
+       ; tau_ty <- tauTvsForReturnTvs res_ty
        ; b1' <- tcMonoExpr b1 tau_ty
        ; b2' <- tcMonoExpr b2 tau_ty
-       ; return $ mkHsWrap wrap $ HsIf Nothing pred' b1' b2' }
+       ; tcWrapResult (HsIf Nothing pred' b1' b2') tau_ty res_ty }
 
 tcExpr (HsIf (Just fun) pred b1 b2) res_ty
   -- Note [Rebindable syntax for if]
index 4bf725f..01853dc 100644 (file)
@@ -22,6 +22,7 @@ module TcMType (
   newReturnTyVar, newReturnTyVarTy,
   newMetaKindVar, newMetaKindVars,
   mkTcTyVarName, cloneMetaTyVar,
+  tauTvsForReturnTvs,
 
   newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
   newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar,
@@ -435,6 +436,26 @@ newReturnTyVar kind = newMetaTyVar ReturnTv kind
 newReturnTyVarTy :: Kind -> TcM TcType
 newReturnTyVarTy kind = TyVarTy <$> newReturnTyVar kind
 
+-- | Replace all the ReturnTvs in a type with TauTvs. These types are
+-- *not* then unified. The caller may wish to do that. No variables
+-- are looked through here. Similarly, no synonyms are looked through,
+-- as doing so won't expose more ReturnTvs.
+tauTvsForReturnTvs :: TcType -> TcM TcType
+tauTvsForReturnTvs = go emptyTvSubst
+  where
+    go env ty@(TyVarTy tv)
+      | isReturnTyVar tv     = newFlexiTyVarTy (substTy env (tyVarKind tv))
+      | otherwise            = return $ substTy env ty
+    go env (AppTy ty1 ty2)   = AppTy <$> go env ty1 <*> go env ty2
+    go env (TyConApp tc tys) = TyConApp tc <$> mapM (go env) tys
+    go env (FunTy ty1 ty2)   = FunTy <$> go env ty1 <*> go env ty2
+    go env (ForAllTy tv ty)
+      = do { k <- go env (tyVarKind tv)
+           ; let tv'  = setTyVarKind tv k
+                 env' = extendTvSubst env tv (TyVarTy tv')
+           ; ForAllTy tv' <$> go env' ty }
+    go _   ty@(LitTy {})     = return ty
+
 tcInstTyVars :: [TKVar] -> TcM (TvSubst, [TcTyVar])
 -- Instantiate with META type variables
 -- Note that this works for a sequence of kind and type
index fc3c18a..940679c 100644 (file)
@@ -186,17 +186,14 @@ data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
 
 tcMatches ctxt pat_tys rhs_ty group@(MG { mg_alts = matches, mg_origin = origin })
   = ASSERT( not (null matches) )        -- Ensure that rhs_ty is filled in
-    do  { (wrap, rhs_ty') <-
+    do  { rhs_ty' <-
              if isSingletonMatchGroup group
                   -- no need to monomorphise the RHS if there's only one
-             then return (idHsWrapper, rhs_ty)
+             then return rhs_ty
                   -- TODO (RAE): Document this behavior.
-             else do { tau_ty <- newFlexiTyVarTy openTypeKind
-                     ; wrap   <- tcSubTypeDS GenSigCtxt tau_ty rhs_ty
-                     ; tau_ty <- zonkTcType tau_ty
-                         -- seems more efficient to zonk just once
-                     ; return (wrap, tau_ty) }
+             else tauTvsForReturnTvs rhs_ty
         ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty') matches
+        ; wrap <- tcSubTypeHR rhs_ty' rhs_ty
         ; return (wrap, MG { mg_alts = matches'
                            , mg_arg_tys = pat_tys
                            , mg_res_ty = rhs_ty'