Fix bugs on implementation of \upsilon types

5 files changed, 29 insertions, 22 deletions

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 50f6cf0a43..59d67f8d86 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -1744,19 +1744,19 @@ can_instance_inst ev lhs rhs
          ; let qvars' = map mkTyVarTy qvars
                evars' = map ctev_evar new_ev_qs
          ; if isUpsilonTy ty
-           then do { let inst = mkInstanceOfPred ty rhs
-                   ; new_ev_inst <- newWantedEvVarNC loc inst
-                   ; setWantedEvBind evar
-                       (mkInstanceOfInst lhs qvars' (ctEvId new_ev_inst) evars')
-                   ; emitWorkNC new_ev_qs
-                   ; traceTcS "can_instance_of/INST" (vcat [ ppr new_ev_inst, ppr new_ev_qs ])
-                   ; canInstanceOfNC new_ev_inst }
                 -- if the inner type is upsilon, generate equality
-           else do { let eq = mkTcEqPredRole Nominal ty rhs
+           then do { let eq = mkTcEqPredRole Nominal ty rhs
                    ; new_ev_eq <- newWantedEvVarNC loc eq
                    ; setWantedEvBind evar
                        (mkInstanceOfInstEq lhs qvars' (ctEvCoercion new_ev_eq) evars')
                    ; emitWorkNC new_ev_qs
                    ; traceTcS "can_instance_of/INSTEQ" (vcat [ ppr new_ev_eq, ppr new_ev_qs ])
-                   ; canEqNC new_ev_eq NomEq ty rhs } }
+                   ; canEqNC new_ev_eq NomEq ty rhs }
+           else do { let inst = mkInstanceOfPred ty rhs
+                   ; new_ev_inst <- newWantedEvVarNC loc inst
+                   ; setWantedEvBind evar
+                       (mkInstanceOfInst lhs qvars' (ctEvId new_ev_inst) evars')
+                   ; emitWorkNC new_ev_qs
+                   ; traceTcS "can_instance_of/INST" (vcat [ ppr new_ev_inst, ppr new_ev_qs ])
+                   ; canInstanceOfNC new_ev_inst } }
     _ -> stopWith ev "Given/Derived instanceOf instantiation"
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 9b73562c44..7f7a476d49 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1009,19 +1009,20 @@ tc_app fun_expr args fun_ty res_ty
         -- Without it, the `a` coming from `f` cannot be unified with
         -- the second type variable of `error`
         ; if isUpsilonTy actual_res_ty
-             then do { ev_res <- addErrCtxtM (funResCtxt True (unLoc fun_expr) actual_res_ty res_ty) $
-                                 emitWanted AppOrigin (mkInstanceOfPred actual_res_ty res_ty)
+             then do { co_res <- addErrCtxtM (funResCtxt True (unLoc fun_expr) actual_res_ty res_ty) $
+                                 unifyType actual_res_ty res_ty
                      ; return $ TcAppResult
                         (mkLHsWrapCo co_fun fun_expr)  -- Instantiated function
                         args1                          -- Arguments
-                                                       -- Coercion to expected result type
-                        (mkWpInstanceOf ev_res) }
-             else do { co_res <- addErrCtxtM (funResCtxt True (unLoc fun_expr) actual_res_ty res_ty) $
-                                 unifyType actual_res_ty res_ty
+                        (coToHsWrapper co_res) }       -- Coercion to expected result type
+             else do { ev_res <- addErrCtxtM (funResCtxt True (unLoc fun_expr) actual_res_ty res_ty) $
+                                 emitWanted AppOrigin (mkInstanceOfPred actual_res_ty res_ty)
                      ; return $ TcAppResult
                         (mkLHsWrapCo co_fun fun_expr)  -- Instantiated function
                         args1                          -- Arguments
-                        (coToHsWrapper co_res) } }     -- Coercion to expected result type
+                                                       -- Coercion to expected result type
+                        (mkWpInstanceOf ev_res) } }
+
 
 mk_app_msg :: Outputable a => a -> SDoc
 mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs
index f439675f3d..aafb5209e5 100644
--- a/compiler/typecheck/TcRules.hs
+++ b/compiler/typecheck/TcRules.hs
@@ -73,8 +73,10 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
                tcExtendIdEnv    id_bndrs $
                do { -- See Note [Solve order for RULES]
                     ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
+                  ; (lhs_inst_simple, _) <- runTcS (instantiateCts (wc_simple lhs_wanted))
+                  ; let lhs_inst = lhs_wanted { wc_simple = lhs_inst_simple }
                   ; (rhs', rhs_wanted) <- captureConstraints (tcPolyMonoExpr rhs rule_ty)
-                  ; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) }
+                  ; return (lhs', lhs_inst, rhs', rhs_wanted, rule_ty) }
 
        ; (lhs_evs, other_lhs_wanted) <- simplifyRule (snd $ unLoc name)
                                                      (bndr_wanted `andWC` lhs_wanted)
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index f080c095cd..e95c9f7e77 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -9,7 +9,8 @@ module TcSimplify(
        solveWantedsTcM,
 
        -- For Rules we need these three
-       solveWanteds, runTcS, instantiateWC
+       solveWanteds, runTcS, approximateWC,
+       instantiateCts
   ) where
 
 #include "HsVersions.h"
@@ -1327,7 +1328,7 @@ defaultTyVar the_tv
   | otherwise = return the_tv    -- The common case
 
 approximateWC :: WantedConstraints -> TcS Cts
-approximateWC = fmap andManyCts . mapM instantiateWC . bagToList . approximateWC_
+approximateWC = instantiateCts . approximateWC_
 
 approximateWC_ :: WantedConstraints -> Cts
 -- Postcondition: Wanted or Derived Cts
@@ -1362,8 +1363,11 @@ approximateWC_ wc
     do_bag :: (a -> Bag c) -> Bag a -> Bag c
     do_bag f = foldrBag (unionBags.f) emptyBag
 
-instantiateWC :: Ct -> TcS Cts
-instantiateWC ct
+instantiateCts :: Cts -> TcS Cts
+instantiateCts = fmap andManyCts . mapM instantiateCt . bagToList
+
+instantiateCt :: Ct -> TcS Cts
+instantiateCt ct
   | isWantedCt ct, InstanceOfPred lhs rhs <- classifyPredType (ctPred ct)
   = do { let loc = ctLoc ct
        ; (_qvars, q, ty) <- deeplySplitInst lhs
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index b27e4f693b..425d0f55cb 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -1429,7 +1429,7 @@ isUpsilonTy ty
   | isSigmaTy ty = False
   | Just v       <- tcGetTyVar_maybe ty      = not (isImmutableTyVar v)
   | Just (tc, _) <- tcSplitTyConApp_maybe ty = isFamilyTyCon tc
-  | otherwise    = True
+  | otherwise    = False
 
 isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy,
     isUnitTy, isCharTy, isAnyTy :: Type -> Bool