From a2a9006b068ba9af9d41711307a8d597d2bb03d7 Mon Sep 17 00:00:00 2001 From: Xavier Denis Date: Mon, 15 Jun 2020 11:37:16 +0200 Subject: Fix issue #18262 by zonking constraints after solving Zonk residual constraints in checkForExistence to reveal user type errors. Previously when `:instances` was used with instances that have TypeError constraints the result would look something like: instance [safe] s0 => Err 'A -- Defined at ../Bug2.hs:8:10 whereas after zonking, `:instances` now sees the `TypeError` and properly eliminates the constraint from the results. --- compiler/GHC/Runtime/Eval.hs | 30 +++++++++++++----------------- docs/users_guide/ghci.rst | 19 +++++++++++++++++++ testsuite/tests/ghci/T18262/T18262.hs | 10 ++++++++++ testsuite/tests/ghci/T18262/T18262.script | 6 ++++++ testsuite/tests/ghci/T18262/T18262.stdout | 1 + testsuite/tests/ghci/T18262/all.T | 1 + 6 files changed, 50 insertions(+), 17 deletions(-) create mode 100644 testsuite/tests/ghci/T18262/T18262.hs create mode 100644 testsuite/tests/ghci/T18262/T18262.script create mode 100644 testsuite/tests/ghci/T18262/T18262.stdout create mode 100644 testsuite/tests/ghci/T18262/all.T diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 3755d8d84f..e88dfc3277 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -118,11 +118,8 @@ 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.Solver (simplifyWantedsTcM) 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) -- ----------------------------------------------------------------------------- @@ -1069,24 +1066,22 @@ parseInstanceHead str = withSession $ \hsc_env0 -> do return ty -- Get all the constraints required of a dictionary binding -getDictionaryBindings :: PredType -> TcM WantedConstraints +getDictionaryBindings :: PredType -> TcM CtEvidence getDictionaryBindings theta = do dictName <- newName (mkDictOcc (mkVarOcc "magic")) let dict_var = mkVanillaGlobal dictName theta loc <- getCtLocM (GivenOrigin UnkSkol) Nothing - -- Generate a wanted constraint here because at the end of constraint + -- Generate a wanted 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 { + return 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])] @@ -1142,17 +1137,18 @@ checkForExistence clsInst mb_inst_tys = do -- thetas of clsInst. (tys, thetas) <- instDFunType (is_dfun clsInst) mb_inst_tys wanteds <- mapM getDictionaryBindings thetas - (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds)) - - let WC { wc_simple = simples, wc_impl = impls } = (dropDerivedWC residuals) + -- It's important to zonk constraints after solving in order to expose things like TypeErrors + -- which otherwise appear as opaque type variables. (See #18262). + WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds - let resPreds = mapBag ctPred simples - - if allBag isSatisfiablePred resPreds && solvedImplics impls - then return . Just $ substInstArgs tys (bagToList resPreds) clsInst + if allBag allowedSimple simples && solvedImplics impls + then return . Just $ substInstArgs tys (bagToList (mapBag ctPred simples)) clsInst else return Nothing where + allowedSimple :: Ct -> Bool + allowedSimple ct = isSatisfiablePred (ctPred ct) + solvedImplics :: Bag Implication -> Bool solvedImplics impls = allBag (isSolvedStatus . ic_status) impls diff --git a/docs/users_guide/ghci.rst b/docs/users_guide/ghci.rst index ce0734cfc2..390719ff80 100644 --- a/docs/users_guide/ghci.rst +++ b/docs/users_guide/ghci.rst @@ -2518,6 +2518,25 @@ commonly used commands. instance Show _ => Show (Maybe _) -- Defined in ‘GHC.Show’ instance Read _ => Read (Maybe _) -- Defined in ‘GHC.Read’ + Only instances which could potentially be used will be displayed in the results. + Instances which require unsatisfiable constraints such as ``TypeError`` will not be + included. In the following example, the instance for ``A`` is not shown because it cannot + be used. + + .. code-block:: none + ghci>:set -XDataKinds -XUndecidableInstances + ghci>import GHC.TypeLits + ghci>class A a + ghci>instance (TypeError (Text "Not possible")) => A Bool + ghci>:instances Bool + instance Eq Bool -- Defined in ‘GHC.Classes’ + instance Ord Bool -- Defined in ‘GHC.Classes’ + instance Enum Bool -- Defined in ‘GHC.Enum’ + instance Show Bool -- Defined in ‘GHC.Show’ + instance Read Bool -- Defined in ‘GHC.Read’ + instance Bounded Bool -- Defined in ‘GHC.Enum’ + + .. ghci-cmd:: :issafe; [⟨module⟩] Displays Safe Haskell information about the given module (or the diff --git a/testsuite/tests/ghci/T18262/T18262.hs b/testsuite/tests/ghci/T18262/T18262.hs new file mode 100644 index 0000000000..1734de0179 --- /dev/null +++ b/testsuite/tests/ghci/T18262/T18262.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances, DataKinds, UndecidableInstances #-} + +import GHC.TypeLits + +data C = A | B + +class Err (a :: C) + +instance (TypeError ('Text "uh-oh")) => Err 'A +instance Err 'B diff --git a/testsuite/tests/ghci/T18262/T18262.script b/testsuite/tests/ghci/T18262/T18262.script new file mode 100644 index 0000000000..9b70743fad --- /dev/null +++ b/testsuite/tests/ghci/T18262/T18262.script @@ -0,0 +1,6 @@ +:load T18262.hs +:set -XDataKinds +-- Should report no instances +:instances 'A +-- Should report an instance with no constraints +:instances 'B diff --git a/testsuite/tests/ghci/T18262/T18262.stdout b/testsuite/tests/ghci/T18262/T18262.stdout new file mode 100644 index 0000000000..76d7e8a596 --- /dev/null +++ b/testsuite/tests/ghci/T18262/T18262.stdout @@ -0,0 +1 @@ +instance [safe] Err 'B -- Defined at T18262.hs:10:10 diff --git a/testsuite/tests/ghci/T18262/all.T b/testsuite/tests/ghci/T18262/all.T new file mode 100644 index 0000000000..fe8e28fe6d --- /dev/null +++ b/testsuite/tests/ghci/T18262/all.T @@ -0,0 +1 @@ +test('T18262', [extra_files(['T18262.hs'])], ghci_script, ['T18262.script']) -- cgit v1.2.1