diff options
| -rw-r--r-- | compiler/hsSyn/HsPat.hs | 8 | ||||
| -rw-r--r-- | compiler/typecheck/TcPat.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcSimplify.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/dependent/should_compile/T11711.hs | 58 | ||||
| -rw-r--r-- | testsuite/tests/dependent/should_compile/all.T | 1 | ||||
| -rw-r--r-- | 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 36c4fafc8f..e01c6b9d07 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -419,9 +419,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 95946460e1..ae3c202d1f 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -816,7 +816,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 b99823e728..0d1e75454f 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -125,10 +125,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 0000000000..633ae35e64 --- /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 783fa16f55..8ecd105a09 100644 --- a/testsuite/tests/dependent/should_compile/all.T +++ b/testsuite/tests/dependent/should_compile/all.T @@ -17,3 +17,4 @@ 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, ['']) diff --git a/testsuite/tests/patsyn/should_fail/mono.stderr b/testsuite/tests/patsyn/should_fail/mono.stderr index 2bed60eafb..20714e7565 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 |