diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs index 15f2bdd4405556bd317ffa8e569f9ec72a853ea4..e36e269ab95cf9f84231cf677db0bb6518e9f6fc 100644 --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -11,9 +11,10 @@ module GHC.Tc.Gen.Default ( tcDefaults ) where import GHC.Prelude import GHC.Hs +import GHC.Builtin.Types.Prim ( concretePrimTyCon ) import GHC.Core.Class -import GHC.Core.Type ( typeKind ) -import GHC.Types.Var( tyVarKind ) +import GHC.Core.Type ( typeKind, isRuntimeRepTy, isLevityTy ) +import GHC.Types.Var ( tyVarKind ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env @@ -71,7 +72,10 @@ tcDefaults decls@(L locn (DefaultDecl _ _) : _) = setSrcSpan (locA locn) $ failWithTc (dupDefaultDeclErr decls) - +-- | Check the validity of a type in a default declaration: +-- +-- - the type must be an instance of at least one of the default classes, or +-- - it must be a concrete type of kind RuntimeRep/Levity. tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type tc_default_ty deflt_clss hs_ty = do { ty <- solveEqualities "tc_default_ty" $ @@ -79,9 +83,15 @@ tc_default_ty deflt_clss hs_ty ; ty <- zonkTcTypeToType ty -- establish Type invariants ; checkValidType DefaultDeclCtxt ty - -- Check that the type is an instance of at least one of the deflt_clss + -- Check that the type is an instance of at least one of the deflt_clss, + -- or is a concrete RuntimeRep/Levity (for representation-polymorphism defaulting) + ; let ki = typeKind ty + ; rep_poly_default + <- if isRuntimeRepTy ki || isLevityTy ki + then simplifyDefault [mkTyConApp concretePrimTyCon [ki, ty]] + else return False ; oks <- mapM (check_instance ty) deflt_clss - ; checkTc (or oks) (TcRnBadDefaultType ty deflt_clss) + ; checkTc (or (rep_poly_default : oks)) (TcRnBadDefaultType ty deflt_clss) ; return ty } check_instance :: Type -> Class -> TcM Bool diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 389720d8f08a900751cf1ccd8410325d8d20b035..919f9178ea3646826229e498419684ce19edd954 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE ViewPatterns #-} module GHC.Tc.Solver( InferMode(..), simplifyInfer, findInferredDiff, @@ -65,7 +65,8 @@ import GHC.Utils.Panic import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Basic ( IntWithInf, intGtLimit - , DefaultKindVars(..), allVarsOfKindDefault ) + , DefaultKindVars(..) + , allVarsOfKindDefault ) import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt @@ -73,6 +74,7 @@ import Control.Monad import Data.Foldable ( toList ) import Data.List ( partition ) import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Maybe ( mapMaybe ) {- ********************************************************************************* @@ -1452,19 +1454,26 @@ decideMonoTyVars infer_mode name_taus psigs candidates pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType]) -- Split the candidates into ones we definitely -- won't quantify, and ones that we might - pick NoRestrictions cand = return ([], cand) + pick NoRestrictions cand = return (partition is_concrete cand) pick ApplyMR cand = return (cand, []) pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings - ; return (partition (is_int_ct os) cand) } + ; return (partition (\ pty -> is_int_ct os pty || is_concrete pty) cand) } -- For EagerDefaulting, do not quantify over -- over any interactive class constraint + is_int_ct :: Bool -> PredType -> Bool is_int_ct ovl_strings pred | Just (cls, _) <- getClassPredTys_maybe pred = isInteractiveClass ovl_strings cls | otherwise = False + -- Never quantify over variables mentioned under a Concrete# constraint, + -- as that would cause a representation-polymorphism error. + is_concrete :: PredType -> Bool + is_concrete (classifyPredType -> SpecialPred ConcretePrimPred _) = True + is_concrete _ = False + ------------------- defaultTyVarsAndSimplify :: TcLevel -> TyCoVarSet @@ -1478,13 +1487,17 @@ defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs) ; any_promoted <- promoteTyVarSet mono_tvs - -- Default any kind/levity vars + -- Find candidates tyvars for defaulting ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes candidates -- any covars should already be handled by -- the logic in decideMonoTyVars, which looks at -- the constraints generated + -- Default kind variables with -XNoPolyKinds, + -- and variables of kind Multiplicity. + -- Don't default RuntimeRep/Levity tyvars when inferring: + -- use typeclass-like defaulting instead (#17201). ; poly_kinds <- xoptM LangExt.PolyKinds ; default_kvs <- mapM (default_one poly_kinds True) (dVarSetElems cand_kvs) @@ -2617,7 +2630,8 @@ applyDefaultingRules wanteds ; traceTcS "applyDefaultingRules {" $ vcat [ text "wanteds =" <+> ppr wanteds , text "groups =" <+> ppr groups - , text "info =" <+> ppr info ] + , text "info =" <+> ppr info + , text "WC =" <+> ppr (approximateWC True wanteds) ] ; something_happeneds <- mapM (disambigGroup default_tys) groups @@ -2651,29 +2665,40 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds | group'@((_,_,tv) :| _) <- unary_groups , let group = toList group' , defaultable_tyvar tv - , defaultable_classes (map sndOf3 group) ] + , defaultable_classes (mapMaybe sndOf3 group) ] where simples = approximateWC True wanteds (unaries, non_unaries) = partitionWith find_unary (bagToList simples) unary_groups = equivClasses cmp_tv unaries - unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints - unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints - non_unaries :: [Ct] -- and *other* constraints + unary_groups :: [NonEmpty (Ct, Maybe Class, TcTyVar)] -- (C tv) constraints + unaries :: [(Ct, Maybe Class, TcTyVar)] -- (C tv) constraints + non_unaries :: [Ct] -- and *other* constraints -- Finds unary type-class constraints -- But take account of polykinded classes like Typeable, -- which may look like (Typeable * (a:*)) (#8931) - find_unary :: Ct -> Either (Ct, Class, TyVar) Ct + find_unary :: Ct -> Either (Ct, Maybe Class, TyVar) Ct find_unary cc - | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) - , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys - -- Ignore invisible arguments for this purpose + | Just (mb_cls, ty) <- defaultable_unary_arg_maybe cc , Just tv <- tcGetTyVar_maybe ty , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and -- we definitely don't want to try to assign to those! - = Left (cc, cls, tv) - find_unary cc = Right cc -- Non unary or non dictionary + = Left (cc, mb_cls, tv) + find_unary cc = Right cc -- Non unary or non dictionary + + defaultable_unary_arg_maybe :: Ct -> Maybe (Maybe Class, Type) + defaultable_unary_arg_maybe cc = + case classifyPredType (ctPred cc) of + ClassPred cls tys + | [ty] <- filterOutInvisibleTypes (classTyCon cls) tys + -- Ignore invisible arguments for this purpose + -> Just (Just cls, ty) + SpecialPred ConcretePrimPred ty + -- We also want to do typeclass-like defaulting for the Concrete# predicate. + -- See #17201. + -> Just (Nothing, ty) + _ -> Nothing bad_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index ad74d919ab7060ff3d2ee1df425496b99fab4320..68a766d9f2bad8dea63fcb2518919f566d67dd47 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -6,6 +6,7 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module GHC.Tc.Utils.Env( TyThing(..), TcTyThing(..), TcId, @@ -134,6 +135,7 @@ import qualified GHC.LanguageExtensions as LangExt import Data.IORef import Data.List (intercalate) +import Data.Monoid (Any(Any)) import Control.Monad import GHC.Driver.Env.KnotVars @@ -957,24 +959,42 @@ tcGetDefaultTys ; mb_defaults <- getDeclaredDefaultTys ; case mb_defaults of { - Just tys -> return (tys, flags) ; - -- User-supplied defaults - Nothing -> do - -- No use-supplied default - -- Use [Integer, Double], plus modifications + -- There are user-supplied defaulting rules: just use these. + -- For backwards compatibility, we also add LiftedRep :: RuntimeRep and Lifted :: Levity + -- as defaults, unless the user has provided defaults at either of those two kinds. + Just tys -> return (add_missing_runtimeRep_levity_defaults tys, flags) ; + + -- No user-supplied defaults, so we supply the following: + -- - Integer, Double for numeric typeclasses, as per the Haskell 98 Report + -- - () :: Type, [] :: Type -> Type with extended default rules + -- - LiftedRep :: RuntimeRep, Lifted :: Levity, for representation-polymorphism defaulting + -- - String with -XOverloadedStrings + Nothing -> do { integer_ty <- tcMetaTy integerTyConName ; list_ty <- tcMetaTy listTyConName ; checkWiredInTyCon doubleTyCon ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty] -- Note [Extended defaults] - ++ [integer_ty, doubleTy] + ++ [integer_ty, doubleTy, liftedRepTy, liftedDataConTy] ++ opt_deflt ovl_strings [stringTy] ; return (deflt_tys, flags) } } } where opt_deflt True xs = xs opt_deflt False _ = [] + -- We always want to have defaults for RuntimeRep and Levity, + -- so we provide the defaults LiftedRep :: RuntimeRep and Lifted :: Levity + -- when the user doesn't provide any defaults at kind RuntimeRep/Levity. + add_missing_runtimeRep_levity_defaults :: [Type] -> [Type] + add_missing_runtimeRep_levity_defaults tys + = (if has_runtimeRep then id else (liftedRepTy :)) + $ (if has_levity then id else (liftedDataConTy :)) + tys + where + (Any has_runtimeRep, Any has_levity) + = foldMap (\ (typeKind -> ki) -> (Any (isRuntimeRepTy ki), Any (isLevityTy ki))) tys + {- Note [Extended defaults] ~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index 9f6d1e1284cf277c663457fe8be6cc1883d120db..26d3da34bd0c103f4495a4bd74696229260237cd 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -1822,7 +1822,7 @@ defaultTyVar def_kindVars def_varsOfKind tv ; return True } | isMultiplicityVar tv , def_multiplicity def_varsOfKind - = do { traceTc "Defaulting a Multiplicty var to Many" (ppr tv) + = do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv) ; writeMetaTyVar tv manyDataConTy ; return True } diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 8717d30a4b0d4f2849caf50662c4cc5b4c764a9c..a4ced287b7da01016451d82524f296a0c9f4c6f7 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -103,6 +103,7 @@ module GHC.Types.Basic ( DefaultKindVars(..), DefaultVarsOfKind(..), allVarsOfKindDefault, noVarsOfKindDefault, + varsOfKindMultiplicityDefault, ForeignSrcLang (..) ) where @@ -1805,3 +1806,8 @@ noVarsOfKindDefault = , def_levity = False , def_multiplicity = False } + +-- | Default type variables of kind `Multiplicity`, but not `RuntimeRep` or `Levity` +varsOfKindMultiplicityDefault :: DefaultVarsOfKind +varsOfKindMultiplicityDefault = + noVarsOfKindDefault { def_multiplicity = True } diff --git a/testsuite/tests/rep-poly/T17201a.hs b/testsuite/tests/rep-poly/T17201a.hs new file mode 100644 index 0000000000000000000000000000000000000000..5e78c06a390bcd8fbb31ba4a9e8631cb521c9d8b --- /dev/null +++ b/testsuite/tests/rep-poly/T17201a.hs @@ -0,0 +1,12 @@ + +{-# LANGUAGE ScopedTypeVariables #-} + +module T17201a where + +import Data.Kind +import GHC.Exts + +f1 :: forall (p :: RuntimeRep -> Type) (r :: RuntimeRep). p r -> p r +f1 x = x + +g1 = f1 diff --git a/testsuite/tests/rep-poly/T17201a.stderr b/testsuite/tests/rep-poly/T17201a.stderr new file mode 100644 index 0000000000000000000000000000000000000000..856591988b1cc9bf8003dc302275ea6cebcdaae0 --- /dev/null +++ b/testsuite/tests/rep-poly/T17201a.stderr @@ -0,0 +1,16 @@ +TYPE SIGNATURES + f1 :: forall (p :: RuntimeRep -> *) (r :: RuntimeRep). p r -> p r + g1 :: + forall {p :: RuntimeRep -> *}. + p ('BoxedRep 'Lifted) -> p ('BoxedRep 'Lifted) +Dependent modules: [] +Dependent packages: [base-4.16.0.0] + +==================== Typechecker ==================== +T17201a.$trModule + = GHC.Types.Module + (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "T17201a"#) +f1 x = x +g1 = f1 + + diff --git a/testsuite/tests/rep-poly/T17201b.hs b/testsuite/tests/rep-poly/T17201b.hs new file mode 100644 index 0000000000000000000000000000000000000000..0de62799f73d7f130527588648cc5fc5069d1002 --- /dev/null +++ b/testsuite/tests/rep-poly/T17201b.hs @@ -0,0 +1,11 @@ + +{-# LANGUAGE ScopedTypeVariables #-} + +module T17201b where + +import Data.Kind +import GHC.Exts + +-- f :: forall r. (a :: TYPE r). a -> a +-- Should default r to LiftedRep. +f x = x diff --git a/testsuite/tests/rep-poly/T17201b.stderr b/testsuite/tests/rep-poly/T17201b.stderr new file mode 100644 index 0000000000000000000000000000000000000000..f20d4fbadd56a4e2afa415e47b061d46757811e0 --- /dev/null +++ b/testsuite/tests/rep-poly/T17201b.stderr @@ -0,0 +1,12 @@ +TYPE SIGNATURES + f :: forall {p}. p -> p +Dependent modules: [] +Dependent packages: [base-4.16.0.0] + +==================== Typechecker ==================== +T17201b.$trModule + = GHC.Types.Module + (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "T17201b"#) +f x = x + + diff --git a/testsuite/tests/rep-poly/T17201c.hs b/testsuite/tests/rep-poly/T17201c.hs new file mode 100644 index 0000000000000000000000000000000000000000..f6cd46c9e2cb854c9ff30e39655d007ec7caa083 --- /dev/null +++ b/testsuite/tests/rep-poly/T17201c.hs @@ -0,0 +1,13 @@ + +{-# LANGUAGE ScopedTypeVariables #-} + +module T17201b where + +import Data.Kind +import GHC.Exts + +default (UnliftedRep) + +-- f :: forall r. (a :: TYPE r). a -> a +-- Should default r to UnliftedRep because of the user-supplied default. +f x = x diff --git a/testsuite/tests/rep-poly/T17201c.stderr b/testsuite/tests/rep-poly/T17201c.stderr new file mode 100644 index 0000000000000000000000000000000000000000..f20d4fbadd56a4e2afa415e47b061d46757811e0 --- /dev/null +++ b/testsuite/tests/rep-poly/T17201c.stderr @@ -0,0 +1,12 @@ +TYPE SIGNATURES + f :: forall {p}. p -> p +Dependent modules: [] +Dependent packages: [base-4.16.0.0] + +==================== Typechecker ==================== +T17201b.$trModule + = GHC.Types.Module + (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "T17201b"#) +f x = x + + diff --git a/testsuite/tests/rep-poly/T17201d.hs b/testsuite/tests/rep-poly/T17201d.hs new file mode 100644 index 0000000000000000000000000000000000000000..ccce04973e93441f6e2134f55a6a057c5693bb4e --- /dev/null +++ b/testsuite/tests/rep-poly/T17201d.hs @@ -0,0 +1,11 @@ + +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module T17201d where + +import Data.Kind +import GHC.Exts + +f x = x +g _ = f 0# diff --git a/testsuite/tests/rep-poly/T17201d.stderr b/testsuite/tests/rep-poly/T17201d.stderr new file mode 100644 index 0000000000000000000000000000000000000000..64bbe1e1e65c3f90255694fd5a64600958573765 --- /dev/null +++ b/testsuite/tests/rep-poly/T17201d.stderr @@ -0,0 +1,14 @@ +TYPE SIGNATURES + f :: forall {p :: TYPE 'IntRep}. p -> p + g :: forall {p}. p -> Int# +Dependent modules: [] +Dependent packages: [base-4.16.0.0] + +==================== Typechecker ==================== +T17201d.$trModule + = GHC.Types.Module + (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "T17201d"#) +f x = x +g _ = f 0# + + diff --git a/testsuite/tests/rep-poly/all.T b/testsuite/tests/rep-poly/all.T index c3b6e9eae657bb9576543e1f1ba84f75e0cdf31d..a45a1bab4c8ca28b9a28e2e64c5bac4152975aec 100644 --- a/testsuite/tests/rep-poly/all.T +++ b/testsuite/tests/rep-poly/all.T @@ -3,15 +3,19 @@ test('T11473', normal, compile_fail, ['']) test('T11724', normal, compile_fail, ['']) test('T12709', normal, compile_fail, ['']) test('T12973', normal, compile_fail, ['']) -test('T13105', expect_broken(17201), compile, ['']) +test('T13105', expect_broken(13105), compile, ['']) test('T13233', normal, compile_fail, ['']) test('T13929', normal, compile_fail, ['']) test('T14561', normal, compile_fail, ['']) test('T14561b', normal, compile_fail, ['']) test('T14765', normal, compile_fail, ['']) -test('T17021', expect_broken(17201), compile, ['']) +test('T17021', expect_broken(13105), compile, ['']) +test('T17201a', normal, compile, ['-fprint-explicit-runtime-reps -dsuppress-uniques -ddump-tc']) +test('T17201b', normal, compile, ['-fprint-explicit-runtime-reps -dsuppress-uniques -ddump-tc']) +test('T17201c', normal, compile, ['-fprint-explicit-runtime-reps -dsuppress-uniques -ddump-tc']) +test('T17201d', normal, compile, ['-fprint-explicit-runtime-reps -dsuppress-uniques -ddump-tc']) test('T17360', normal, compile_fail, ['']) -test('T17536b', expect_broken(17201), compile, ['']) +test('T17536b', expect_broken(13105), compile, ['']) test('T17817', normal, compile_fail, ['']) test('T18170a', [extra_files(['T18170c.hs'])], multimod_compile, ['T18170a.hs', '-v0']) test('T18170b', [extra_files(['T18170c.hs']), expect_broken(19893)], multimod_compile_fail, ['T18170b.hs', '-v0']) @@ -28,7 +32,7 @@ test('T20277', normal, compile_fail, ['']) test('T20330a', normal, compile, ['']) test('T20330b', normal, compile, ['']) test('T20363', normal, compile, ['']) -test('T20363b', expect_broken(17201), compile, ['']) +test('T20363b', expect_broken(13105), compile, ['']) test('T20423', normal, compile_fail, ['']) test('T20423b', normal, compile_fail, ['']) test('T20426', normal, compile_fail, [''])