Commit 0ce858e5 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Zonk properly when checkig pattern synonyms

Fixes Trac #10997

Merge to stable branch
parent 68318151
......@@ -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) }
{-
************************************************************************
......
......@@ -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) } }
{-
************************************************************************
......
module T10997 where
import T10997a
foo :: Exp a -> String
foo Tru = "True"
module T10997 where
module T10997_1 where
import T10997a
import T10997_1a
{- With ghc-7.10.2:
......
{-# LANGUAGE PatternSynonyms, ViewPatterns, ConstraintKinds, TypeFamilies, PolyKinds, KindSignatures #-}
module T10997a where
module T10997_1a where
import GHC.Exts
......
{-# LANGUAGE GADTs, PatternSynonyms #-}
module T10997a where
data Exp ty where
LitB :: Bool -> Exp Bool
pattern Tru :: b ~ Bool => Exp b
pattern Tru = LitB True
......@@ -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'])
......@@ -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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment