[commit: ghc] ghc-8.0: Fix #11711. (e3cf12a)
git at git.haskell.org
git at git.haskell.org
Wed Mar 23 16:37:41 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/e3cf12ab4b6ea2ddbc8b23fd2856b575c30948f9/ghc
>---------------------------------------------------------------
commit e3cf12ab4b6ea2ddbc8b23fd2856b575c30948f9
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Wed Mar 16 14:30:00 2016 -0400
Fix #11711.
There were two bugs here, both simple: we need to filter out
covars before calling isMetaTyVar in the solver, and TcPat had
a tcSubType the wrong way round.
test case: dependent/should_compile/T11711
(cherry picked from commit b5565f1a79fd24fc45a6f1a58821a317852d4b89)
>---------------------------------------------------------------
e3cf12ab4b6ea2ddbc8b23fd2856b575c30948f9
compiler/hsSyn/HsPat.hs | 8 +--
compiler/typecheck/TcPat.hs | 2 +-
compiler/typecheck/TcSimplify.hs | 4 +-
testsuite/tests/dependent/should_compile/T11711.hs | 58 ++++++++++++++++++++++
testsuite/tests/dependent/should_compile/all.T | 1 +
testsuite/tests/patsyn/should_fail/mono.stderr | 20 ++++----
6 files changed, 78 insertions(+), 15 deletions(-)
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index 82aeb69..09a38a9 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -421,9 +421,11 @@ pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas
pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
pat_binds = binds, pat_args = details })
- = getPprStyle $ \ sty -> -- Tiresome; in TcBinds.tcRhs we print out a
- if debugStyle sty then -- typechecked Pat in an error message,
- -- and we want to make sure it prints nicely
+ = sdocWithDynFlags $ \dflags ->
+ -- Tiresome; in TcBinds.tcRhs we print out a
+ -- typechecked Pat in an error message,
+ -- and we want to make sure it prints nicely
+ if gopt Opt_PrintTypecheckerElaboration dflags then
ppr con
<> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
, ppr binds])
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index adad0ed..e56bb20 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -821,7 +821,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
prov_theta' = substTheta tenv prov_theta
req_theta' = substTheta tenv req_theta
- ; wrap <- tcSubTypeO (pe_orig penv) GenSigCtxt ty' pat_ty
+ ; wrap <- tcSubTypeET (pe_orig penv) pat_ty ty'
; traceTc "tcPatSynPat" (ppr pat_syn $$
ppr pat_ty $$
ppr ty' $$
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 6ac8ab3..cc5031a 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -133,10 +133,12 @@ simpl_top wanteds
= return wc
| otherwise
= do { free_tvs <- TcS.zonkTyCoVarsAndFV (tyCoVarsOfWC wc)
- ; let meta_tvs = varSetElems (filterVarSet isMetaTyVar free_tvs)
+ ; let meta_tvs = varSetElems $
+ filterVarSet (isTyVar <&&> isMetaTyVar) free_tvs
-- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked
-- filter isMetaTyVar: we might have runtime-skolems in GHCi,
-- and we definitely don't want to try to assign to those!
+ -- the isTyVar needs to weed out coercion variables
; defaulted <- mapM defaultTyVarTcS meta_tvs -- Has unification side effects
; if or defaulted
diff --git a/testsuite/tests/dependent/should_compile/T11711.hs b/testsuite/tests/dependent/should_compile/T11711.hs
new file mode 100644
index 0000000..633ae35
--- /dev/null
+++ b/testsuite/tests/dependent/should_compile/T11711.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module T11711 where
+
+import Data.Kind (Type)
+
+data (:~~:) (a :: k1) (b :: k2) where
+ HRefl :: a :~~: a
+
+data TypeRep (a :: k) where
+ TrTyCon :: String -> TypeRep k -> TypeRep (a :: k)
+ TrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
+ TypeRep (a :: k1 -> k2)
+ -> TypeRep (b :: k1)
+ -> TypeRep (a b)
+
+class Typeable (a :: k) where
+ typeRep :: TypeRep a
+
+data TypeRepX where
+ TypeRepX :: forall k (a :: k). TypeRep a -> TypeRepX
+
+eqTypeRep :: TypeRep a -> TypeRep b -> Maybe (a :~~: b)
+eqTypeRep = undefined
+
+typeRepKind :: forall k (a :: k). TypeRep a -> TypeRep k
+typeRepKind = undefined
+
+instance Typeable Type where
+ typeRep = TrTyCon "Type" typeRep
+
+funResultTy :: TypeRepX -> TypeRepX -> Maybe TypeRepX
+funResultTy (TypeRepX f) (TypeRepX x)
+ | Just HRefl <- (typeRep :: TypeRep Type) `eqTypeRep` typeRepKind f
+ , TRFun arg res <- f
+ , Just HRefl <- arg `eqTypeRep` x
+ = Just (TypeRepX res)
+ | otherwise
+ = Nothing
+
+trArrow :: TypeRep (->)
+trArrow = undefined
+
+pattern TRFun :: forall fun. ()
+ => forall arg res. (fun ~ (arg -> res))
+ => TypeRep arg
+ -> TypeRep res
+ -> TypeRep fun
+pattern TRFun arg res <- TrApp (TrApp (eqTypeRep trArrow -> Just HRefl) arg) res
diff --git a/testsuite/tests/dependent/should_compile/all.T b/testsuite/tests/dependent/should_compile/all.T
index 9da91ce..2f9d311 100644
--- a/testsuite/tests/dependent/should_compile/all.T
+++ b/testsuite/tests/dependent/should_compile/all.T
@@ -17,4 +17,5 @@ test('dynamic-paper', expect_fail_for(['optasm', 'optllvm']), compile, [''])
test('T11311', normal, compile, [''])
test('T11405', normal, compile, [''])
test('T11241', normal, compile, [''])
+test('T11711', normal, compile, [''])
test('RaeJobTalk', normal, compile, [''])
diff --git a/testsuite/tests/patsyn/should_fail/mono.stderr b/testsuite/tests/patsyn/should_fail/mono.stderr
index 2bed60e..20714e7 100644
--- a/testsuite/tests/patsyn/should_fail/mono.stderr
+++ b/testsuite/tests/patsyn/should_fail/mono.stderr
@@ -1,12 +1,12 @@
-mono.hs:7:4:
- Couldn't match type ‘Int’ with ‘Bool’
- Expected type: [Bool]
- Actual type: [Int]
- In the pattern: Single x
- In an equation for ‘f’: f (Single x) = x
+mono.hs:7:4: error:
+ • Couldn't match type ‘Bool’ with ‘Int’
+ Expected type: [Int]
+ Actual type: [Bool]
+ • In the pattern: Single x
+ In an equation for ‘f’: f (Single x) = x
-mono.hs:7:16:
- Couldn't match expected type ‘Bool’ with actual type ‘Int’
- In the expression: x
- In an equation for ‘f’: f (Single x) = x
+mono.hs:7:16: error:
+ • Couldn't match expected type ‘Bool’ with actual type ‘Int’
+ • In the expression: x
+ In an equation for ‘f’: f (Single x) = x
More information about the ghc-commits
mailing list