Coercions from boxy splitters must be sym'ed in pattern matches

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 10946f3..0d62b6b 100644 (file)
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -447,20 +447,25 @@ tc_pat pstate pat@(TypePat ty) pat_ty thing_inside
 -- Lists, tuples, arrays
 tc_pat pstate (ListPat pats _) pat_ty thing_inside
   = do { (elt_ty, coi) <- boxySplitListTy pat_ty
+        ; let scoi = mkSymCoI coi
        ; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
                                                pats pstate thing_inside
-       ; return (mkCoPatCoI coi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) }
+       ; return (mkCoPatCoI scoi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) 
+        }
 
 tc_pat pstate (PArrPat pats _) pat_ty thing_inside
   = do { (elt_ty, coi) <- boxySplitPArrTy pat_ty
+        ; let scoi = mkSymCoI coi
        ; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
                                                pats pstate thing_inside 
        ; ifM (null pats) (zapToMonotype pat_ty)  -- c.f. ExplicitPArr in TcExpr
-       ; return (mkCoPatCoI coi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res) }
+       ; return (mkCoPatCoI scoi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res)
+        }
 
 tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
   = do { let tc = tupleTyCon boxity (length pats)
         ; (arg_tys, coi) <- boxySplitTyConApp tc pat_ty
+        ; let scoi = mkSymCoI coi
        ; (pats', pats_tvs, res) <- tcMultiple tc_lpat_pr (pats `zip` arg_tys)
                                               pstate thing_inside
 
@@ -477,7 +482,7 @@ tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
                | otherwise                 = unmangled_result
 
        ; ASSERT( length arg_tys == length pats )      -- Syntactically enforced
-         return (mkCoPatCoI coi possibly_mangled_result pat_ty, pats_tvs, res) 
+         return (mkCoPatCoI scoi possibly_mangled_result pat_ty, pats_tvs, res)
         }
 
 ------------------------
@@ -610,18 +615,27 @@ tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon
         -> HsConPatDetails Name -> (PatState -> TcM a)
         -> TcM (Pat TcId, [TcTyVar], a)
 tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
-  = do { let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _) = dataConFullSig data_con
+  = do { let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _)
+                = dataConFullSig data_con
              skol_info  = PatSkol data_con
              origin     = SigOrigin skol_info
              full_theta = eq_theta ++ dict_theta
 
          -- Instantiate the constructor type variables [a->ty]
-         -- This may involve doing a family-instance coercion, and building a wrapper
+         -- This may involve doing a family-instance coercion, and building a
+         -- wrapper 
        ; (ctxt_res_tys, coi) <- boxySplitTyConAppWithFamily tycon pat_ty
-       ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
-                                     -- pat_ty /= pat_ty iff coi /= IdCo
-              wrap_res_pat res_pat
-               = mkCoPatCoI coi (unwrapFamInstScrutinee tycon ctxt_res_tys res_pat) pat_ty
+        ; let sym_coi = mkSymCoI coi  -- boxy split coercion oriented wrongly
+             pat_ty' = mkTyConApp tycon ctxt_res_tys
+                                      -- pat_ty' /= pat_ty iff coi /= IdCo
+              
+              wrap_res_pat res_pat = mkCoPatCoI sym_coi uwScrut pat_ty
+                where
+                  uwScrut = unwrapFamInstScrutinee tycon ctxt_res_tys res_pat
+
+        ; traceTc $ case sym_coi of
+                      IdCo -> text "sym_coi:IdCo" 
+                      ACo co -> text "sym_coi: ACoI" <+> ppr co
 
          -- Add the stupid theta
        ; addDataConStupidTheta data_con ctxt_res_tys

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index bd25c51..0893850 100644 (file)
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -222,7 +222,7 @@ subFunTys error_herald n_pats res_ty thing_inside
 boxySplitTyConApp :: TyCon                     -- T :: k1 -> ... -> kn -> *
                  -> BoxyRhoType                -- Expected type (T a b c)
                  -> TcM ([BoxySigmaType],      -- Element types, a b c
-                          CoercionI)
+                          CoercionI)            -- T a b c ~ orig_ty
   -- It's used for wired-in tycons, so we call checkWiredInTyCon
   -- Precondition: never called with FunTyCon
   -- Precondition: input type :: *
@@ -314,7 +314,7 @@ boxySplitAppTy orig_ty
       | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
       = return ((fun_ty, arg_ty), IdCo)
 
-    loop ty@(TyConApp tycon args)
+    loop ty@(TyConApp tycon _args)
       | isOpenSynTyCon tycon        -- try to normalise type family application
       = do { (coi1, ty') <- tcNormaliseFamInst ty
            ; case coi1 of