Zonk properly when checkig pattern synonyms
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 27 Oct 2015 13:27:42 +0000 (13:27 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 27 Oct 2015 13:27:59 +0000 (13:27 +0000)
Fixes Trac #10997

Merge to stable branch

compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcUnify.hs
testsuite/tests/patsyn/should_compile/T10997.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/T10997_1.hs [moved from testsuite/tests/typecheck/should_compile/T10997.hs with 87% similarity]
testsuite/tests/patsyn/should_compile/T10997_1a.hs [moved from testsuite/tests/typecheck/should_compile/T10997a.hs with 95% similarity]
testsuite/tests/patsyn/should_compile/T10997a.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/all.T
testsuite/tests/typecheck/should_compile/all.T

index 529e6b2..121a898 100644 (file)
@@ -84,15 +84,6 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
              prov_theta = map evVarPred prov_dicts
              req_theta  = map evVarPred req_dicts
 
-       ; univ_tvs   <- mapM zonkQuantifiedTyVar univ_tvs
-       ; ex_tvs     <- mapM zonkQuantifiedTyVar ex_tvs
-
-       ; prov_theta <- zonkTcThetaType prov_theta
-       ; req_theta  <- zonkTcThetaType req_theta
-
-       ; pat_ty     <- zonkTcType pat_ty
-       ; args       <- mapM zonkId args
-
        ; traceTc "tcInferPatSynDecl }" $ ppr name
        ; tc_patsyn_finish lname dir is_infix lpat'
                           (univ_tvs, req_theta, ev_binds, req_dicts)
@@ -137,8 +128,8 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
          --  * The arguments, type-coerced to the SigTyVars: wrapped_args
          --  * The instantiation of ex_tvs to pass to the success continuation: ex_tys
          --  * The provided theta substituted with the SigTyVars: prov_theta'
-       ; (req_ev_binds, (lpat', (ex_tys, prov_theta', wrapped_args))) <-
-           checkConstraints skol_info univ_tvs req_dicts $
+       ; (implic1, req_ev_binds, (lpat', (ex_tys, prov_theta', wrapped_args))) <-
+           buildImplication skol_info univ_tvs req_dicts $
            tcPat PatSyn lpat pat_ty $ do
            { ex_sigtvs <- mapM (\tv -> newSigTyVar (getName tv) (tyVarKind tv)) ex_tvs
            ; let subst = mkTvSubst (mkInScopeSet (zipVarEnv ex_sigtvs ex_sigtvs)) $
@@ -156,11 +147,16 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
        ; let ex_tvs_rhs  = varSetElems ex_vars_rhs
 
          -- Check that prov_theta' can be satisfied with the dicts from the pattern
-       ; (prov_ev_binds, prov_dicts) <-
-           checkConstraints skol_info ex_tvs_rhs prov_dicts_rhs $ do
+       ; (implic2, prov_ev_binds, prov_dicts) <-
+           buildImplication skol_info ex_tvs_rhs prov_dicts_rhs $ do
            { let origin = PatOrigin -- TODO
            ; emitWanteds origin prov_theta' }
 
+       -- Solve the constraints now, because we are about to make a PatSyn,
+       -- which should not contain unification variables and the like (Trac #10997)
+       -- Since all the inputs are implications the returned bindings will be empty
+       ; _ <- simplifyTop (emptyWC `addImplics` (implic1 `unionBags` implic2))
+
        ; traceTc "tcCheckPatSynDecl }" $ ppr name
        ; tc_patsyn_finish lname dir is_infix lpat'
                           (univ_tvs, req_theta, req_ev_binds, req_dicts)
@@ -191,20 +187,36 @@ tc_patsyn_finish lname dir is_infix lpat'
                  (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
                  wrapped_args
                  pat_ty
-  = do { traceTc "tc_patsyn_finish {" $
+  = do { -- Zonk everything.  We are about to build a final PatSyn
+         -- so there had better be no unification variables in there
+         univ_tvs     <- mapM zonkQuantifiedTyVar univ_tvs
+       ; ex_tvs       <- mapM zonkQuantifiedTyVar ex_tvs
+       ; prov_theta   <- zonkTcThetaType prov_theta
+       ; req_theta    <- zonkTcThetaType req_theta
+       ; pat_ty       <- zonkTcType pat_ty
+       ; wrapped_args <- mapM zonk_wrapped_arg wrapped_args
+       ; let qtvs    = univ_tvs ++ ex_tvs
+             theta   = prov_theta ++ req_theta
+             arg_tys = map (varType . fst) wrapped_args
+
+       ; traceTc "tc_patsyn_finish {" $
            ppr (unLoc lname) $$ ppr (unLoc lpat') $$
            ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
            ppr (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts) $$
            ppr wrapped_args $$
            ppr pat_ty
+
+       -- Make the 'matcher'
        ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
                                          (univ_tvs, req_theta, req_ev_binds, req_dicts)
                                          (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
-                                         wrapped_args
+                                         wrapped_args  -- Not necessarily zonked
                                          pat_ty
 
+       -- Make the 'builder'
        ; builder_id <- mkPatSynBuilderId dir lname qtvs theta arg_tys pat_ty
 
+       -- Make the PatSyn itself
        ; let patSyn = mkPatSyn (unLoc lname) is_infix
                         (univ_tvs, req_theta)
                         (ex_tvs, prov_theta)
@@ -214,9 +226,10 @@ tc_patsyn_finish lname dir is_infix lpat'
 
        ; return (patSyn, matcher_bind) }
   where
-    qtvs = univ_tvs ++ ex_tvs
-    theta = prov_theta ++ req_theta
-    arg_tys = map (varType . fst) wrapped_args
+    zonk_wrapped_arg :: (Var, HsWrapper) -> TcM (Var, HsWrapper)
+    -- The HsWrapper will get zonked later, as part of the LHsBinds
+    zonk_wrapped_arg (arg_id, wrap) = do { arg_id <- zonkId arg_id
+                                         ; return (arg_id, wrap) }
 
 {-
 ************************************************************************
index 8042cc5..af0b611 100644 (file)
@@ -12,7 +12,7 @@ module TcUnify (
   -- Full-blown subsumption
   tcWrapResult, tcGen,
   tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_NC,
-  checkConstraints,
+  checkConstraints, buildImplication,
 
   -- Various unifications
   unifyType, unifyTypeList, unifyTheta,
@@ -52,6 +52,7 @@ import ErrUtils
 import DynFlags
 import BasicTypes
 import Maybes ( isJust )
+import Bag
 import Util
 import Outputable
 import FastString
@@ -571,7 +572,17 @@ checkConstraints skol_info skol_tvs given thing_inside
       -- tcPolyExpr, which uses tcGen and hence checkConstraints.
 
   | otherwise
-  = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs )
+  = do { (implics, ev_binds, result) <- buildImplication skol_info skol_tvs given thing_inside
+       ; emitImplications implics
+       ; return (ev_binds, result) }
+
+buildImplication :: SkolemInfo
+                 -> [TcTyVar]           -- Skolems
+                 -> [EvVar]             -- Given
+                 -> TcM result
+                 -> TcM (Bag Implication, TcEvBinds, result)
+buildImplication skol_info skol_tvs given thing_inside
+ =  ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs )
     ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs )
     do { (result, tclvl, wanted) <- pushLevelAndCaptureConstraints thing_inside
 
@@ -581,21 +592,21 @@ checkConstraints skol_info skol_tvs given thing_inside
             -- Reason for the (null given): we don't want to lose
             -- the "inaccessible alternative" error check
          then
-            return (emptyTcEvBinds, result)
+            return (emptyBag, emptyTcEvBinds, result)
          else do
        { ev_binds_var <- newTcEvBinds
        ; env <- getLclEnv
-       ; emitImplication $ Implic { ic_tclvl = tclvl
-                                  , ic_skols = skol_tvs
-                                  , ic_no_eqs = False
-                                  , ic_given = given
-                                  , ic_wanted = wanted
-                                  , ic_status  = IC_Unsolved
-                                  , ic_binds = ev_binds_var
-                                  , ic_env = env
-                                  , ic_info = skol_info }
-
-       ; return (TcEvBinds ev_binds_var, result) } }
+       ; let implic = Implic { ic_tclvl = tclvl
+                             , ic_skols = skol_tvs
+                             , ic_no_eqs = False
+                             , ic_given = given
+                             , ic_wanted = wanted
+                             , ic_status  = IC_Unsolved
+                             , ic_binds = ev_binds_var
+                             , ic_env = env
+                             , ic_info = skol_info }
+
+       ; return (unitBag implic, TcEvBinds ev_binds_var, result) } }
 
 {-
 ************************************************************************
diff --git a/testsuite/tests/patsyn/should_compile/T10997.hs b/testsuite/tests/patsyn/should_compile/T10997.hs
new file mode 100644 (file)
index 0000000..69a7940
--- /dev/null
@@ -0,0 +1,6 @@
+module T10997 where
+
+import T10997a
+
+foo :: Exp a -> String
+foo Tru = "True"
@@ -1,6 +1,6 @@
-module T10997 where
+module T10997_1 where
 
-import T10997a
+import T10997_1a
 
 {- With ghc-7.10.2:
 
@@ -1,5 +1,5 @@
 {-# LANGUAGE PatternSynonyms, ViewPatterns, ConstraintKinds, TypeFamilies, PolyKinds, KindSignatures #-}
-module T10997a where
+module T10997_1a where
 
 import GHC.Exts
 
diff --git a/testsuite/tests/patsyn/should_compile/T10997a.hs b/testsuite/tests/patsyn/should_compile/T10997a.hs
new file mode 100644 (file)
index 0000000..bed19f7
--- /dev/null
@@ -0,0 +1,11 @@
+{-# LANGUAGE GADTs, PatternSynonyms #-}
+
+module T10997a where
+
+data Exp ty where
+  LitB :: Bool -> Exp Bool
+
+pattern Tru :: b ~ Bool => Exp b
+pattern Tru = LitB True
+
+
index 9d42fa0..0ff777d 100644 (file)
@@ -26,3 +26,7 @@ test('T9975a', normal, compile_fail, [''])
 test('T9975b', normal, compile, [''])
 test('T10426', [expect_broken(10426)], compile, [''])
 test('T10747', normal, compile, [''])
+test('T10997', [extra_clean(['T10997a.hi', 'T10997a.o'])], multimod_compile, ['T10997', '-v0'])
+test('T10997_1', [extra_clean(['T10997_1a.hi', 'T10997_1a.o'])], multimod_compile, ['T10997_1', '-v0'])
+
+
index d7271b7..ed0c8e1 100644 (file)
@@ -479,5 +479,3 @@ test('T10770a', expect_broken(10770), compile, [''])
 test('T10770b', expect_broken(10770), compile, [''])
 test('T10935', normal, compile, [''])
 test('T10971a', normal, compile, [''])
-test('T10997', expect_broken(10997),
-               multi_compile, ['T10997', [('T10997a.hs', '')], '-v0'])