[Git][ghc/ghc][master] Fix #18071
Marge Bot
gitlab at gitlab.haskell.org
Thu May 28 20:24:48 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
dc5f004c by Xavier Denis at 2020-05-28T16:24:37-04:00
Fix #18071
Run the core linter on candidate instances to ensure they are
well-kinded.
Better handle quantified constraints by using a CtWanted to avoid
having unsolved constraints thrown away at the end by the solver.
- - - - -
5 changed files:
- compiler/GHC/Runtime/Eval.hs
- + testsuite/tests/ghci/T18071/T18071.hs
- + testsuite/tests/ghci/T18071/T18071.script
- + testsuite/tests/ghci/T18071/T18071.stdout
- + testsuite/tests/ghci/T18071/all.T
Changes:
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -64,6 +64,7 @@ import GHC.Core.FamInstEnv ( FamInst )
import GHC.Core.FVs ( orphNamesOfFamInst )
import GHC.Core.TyCon
import GHC.Core.Type hiding( typeKind )
+import qualified GHC.Core.Type as Type
import GHC.Types.RepType
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Constraint
@@ -115,16 +116,14 @@ import Unsafe.Coerce ( unsafeCoerce )
import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces )
import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) )
-
import GHC.Tc.Utils.Env (tcGetInstEnvs)
-
import GHC.Tc.Utils.Instantiate (instDFunType)
import GHC.Tc.Solver (solveWanteds)
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Evidence
import Data.Bifunctor (second)
-
import GHC.Tc.Solver.Monad (runTcS)
+import GHC.Core.Class (classTyCon)
-- -----------------------------------------------------------------------------
-- running a statement interactively
@@ -1056,6 +1055,7 @@ getInstancesForType ty = withSession $ \hsc_env -> do
-- Bring class and instances from unqualified modules into scope, this fixes #16793.
loadUnqualIfaces hsc_env (hsc_IC hsc_env)
matches <- findMatchingInstances ty
+
fmap catMaybes . forM matches $ uncurry checkForExistence
-- Parse a type string and turn any holes into skolems
@@ -1074,13 +1074,41 @@ getDictionaryBindings theta = do
dictName <- newName (mkDictOcc (mkVarOcc "magic"))
let dict_var = mkVanillaGlobal dictName theta
loc <- getCtLocM (GivenOrigin UnkSkol) Nothing
- let wCs = mkSimpleWC [CtDerived
- { ctev_pred = varType dict_var
- , ctev_loc = loc
- }]
+
+ -- Generate a wanted constraint here because at the end of constraint
+ -- solving, most derived constraints get thrown away, which in certain
+ -- cases, notably with quantified constraints makes it impossible to rule
+ -- out instances as invalid. (See #18071)
+ let wCs = mkSimpleWC [CtWanted {
+ ctev_pred = varType dict_var,
+ ctev_dest = EvVarDest dict_var,
+ ctev_nosh = WDeriv,
+ ctev_loc = loc
+ }]
return wCs
+-- Find instances where the head unifies with the provided type
+findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]
+findMatchingInstances ty = do
+ ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs
+ let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local
+ return $ concatMap (try_cls ies) allClasses
+ where
+ {- Check that a class instance is well-kinded.
+ Since `:instances` only works for unary classes, we're looking for instances of kind
+ k -> Constraint where k is the type of the queried type.
+ -}
+ try_cls ies cls
+ | Just (arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls)
+ , tcIsConstraintKind res_kind
+ , Type.typeKind ty `eqType` arg_kind
+ , (matches, _, _) <- lookupInstEnv True ies cls [ty]
+ = matches
+ | otherwise
+ = []
+
+
{-
When we've found an instance that a query matches against, we still need to
check that all the instance's constraints are satisfiable. checkForExistence
@@ -1105,19 +1133,28 @@ getDictionaryBindings theta = do
-}
checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst)
-checkForExistence res mb_inst_tys = do
- (tys, thetas) <- instDFunType (is_dfun res) mb_inst_tys
-
- wanteds <- forM thetas getDictionaryBindings
+checkForExistence clsInst mb_inst_tys = do
+ -- We want to force the solver to attempt to solve the constraints for clsInst.
+ -- Usually, this isn't a problem since there should only be a single instance
+ -- for a type. However, when we have overlapping instances, the solver will give up
+ -- since it can't decide which instance to use. To get around this restriction, instead
+ -- of asking the solver to solve a constraint for clsInst, we ask it to solve the
+ -- thetas of clsInst.
+ (tys, thetas) <- instDFunType (is_dfun clsInst) mb_inst_tys
+ wanteds <- mapM getDictionaryBindings thetas
(residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds))
- let all_residual_constraints = bagToList $ wc_simple residuals
- let preds = map ctPred all_residual_constraints
- if all isSatisfiablePred preds && (null $ wc_impl residuals)
- then return . Just $ substInstArgs tys preds res
+ let WC { wc_simple = simples, wc_impl = impls } = (dropDerivedWC residuals)
+
+ let resPreds = mapBag ctPred simples
+
+ if allBag isSatisfiablePred resPreds && solvedImplics impls
+ then return . Just $ substInstArgs tys (bagToList resPreds) clsInst
else return Nothing
where
+ solvedImplics :: Bag Implication -> Bool
+ solvedImplics impls = allBag (isSolvedStatus . ic_status) impls
-- Stricter version of isTyVarClassPred that requires all TyConApps to have at least
-- one argument or for the head to be a TyVar. The reason is that we want to ensure
@@ -1129,7 +1166,7 @@ checkForExistence res mb_inst_tys = do
Just (_, tys@(_:_)) -> all isTyVarTy tys
_ -> isTyVarTy ty
- empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun res)))
+ empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun clsInst)))
{- Create a ClsInst with instantiated arguments and constraints.
@@ -1149,16 +1186,6 @@ checkForExistence res mb_inst_tys = do
where
(dfun_tvs, _, cls, args) = instanceSig inst
--- Find instances where the head unifies with the provided type
-findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]
-findMatchingInstances ty = do
- ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs
- let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local
-
- concatMapM (\cls -> do
- let (matches, _, _) = lookupInstEnv True ies cls [ty]
- return matches) allClasses
-
-----------------------------------------------------------------------------
-- Compile an expression, run it, and deliver the result
=====================================
testsuite/tests/ghci/T18071/T18071.hs
=====================================
@@ -0,0 +1,32 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DataKinds #-}
+module Bug where
+
+import Data.Kind
+import Data.Proxy
+
+class MyShow a where
+ show :: a -> String
+
+class (forall (z :: k). MyShow (Proxy z)) => MyShowProxy (k :: Type) where
+instance (forall (z :: k). MyShow (Proxy z)) => MyShowProxy (k :: Type)
+
+data T :: Type -> Type
+
+data U = A | B
+
+instance forall (z :: U). MyShow (Proxy (z :: U)) where
+ show _ = "U"
+
+data U2 = A2 | B2
+
+instance MyShow (Proxy A2) where
+ show _ = "A2"
+
+instance MyShow (Proxy B2) where
+ show _ = "B2"
+
=====================================
testsuite/tests/ghci/T18071/T18071.script
=====================================
@@ -0,0 +1,8 @@
+:set -Wno-simplifiable-class-constraints
+:load T18071.hs
+-- Should report no instances since it is ill-kinded for T
+:instances T
+-- U should report a match for ShowProxy
+:instances U
+-- U2 should not report a match for ShowProxy
+:instances U2
=====================================
testsuite/tests/ghci/T18071/T18071.stdout
=====================================
@@ -0,0 +1 @@
+instance [safe] MyShowProxy U -- Defined at T18071.hs:16:10
=====================================
testsuite/tests/ghci/T18071/all.T
=====================================
@@ -0,0 +1 @@
+test('T18071', [extra_files(['T18071.hs'])], ghci_script, ['T18071.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc5f004c4dc27d78d3415adc54e9b6694b865145
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc5f004c4dc27d78d3415adc54e9b6694b865145
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200528/51cbe0e1/attachment-0001.html>
More information about the ghc-commits
mailing list