From 0c3341b23e0672fb9c05d9f6ab0be76f411d526e Mon Sep 17 00:00:00 2001 From: Maciej Bielecki Date: Wed, 14 Dec 2016 16:43:25 -0500 Subject: [PATCH] Show constraints when reporting typed holes This patch implements the display of constraints in the error message for typed holes. Test Plan: validate, read docs Reviewers: simonpj, austin, bgamari Reviewed By: simonpj, bgamari Subscribers: simonpj, thomie Differential Revision: https://phabricator.haskell.org/D2767 GHC Trac Issues: #10614 --- compiler/main/DynFlags.hs | 4 +- compiler/typecheck/TcErrors.hs | 45 +++++++++++++- docs/users_guide/glasgow_exts.rst | 27 ++++++++ .../tests/typecheck/should_compile/all.T | 2 + .../should_compile/hole_constraints.hs | 27 ++++++++ .../should_compile/hole_constraints.stderr | 61 +++++++++++++++++++ .../should_compile/hole_constraints_nested.hs | 12 ++++ .../hole_constraints_nested.stderr | 15 +++++ utils/mkUserGuidePart/Options/Verbosity.hs | 4 ++ 9 files changed, 195 insertions(+), 2 deletions(-) create mode 100644 testsuite/tests/typecheck/should_compile/hole_constraints.hs create mode 100644 testsuite/tests/typecheck/should_compile/hole_constraints.stderr create mode 100644 testsuite/tests/typecheck/should_compile/hole_constraints_nested.hs create mode 100644 testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 578518450d..db234bd65d 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -539,6 +539,7 @@ data GeneralFlag -- instead of just the start position. | Opt_PprCaseAsLet | Opt_PprShowTicks + | Opt_ShowHoleConstraints -- Suppress all coercions, them replacing with '...' | Opt_SuppressCoercions @@ -3654,7 +3655,8 @@ fFlagsDeps = [ flagSpec "version-macros" Opt_VersionMacros, flagSpec "worker-wrapper" Opt_WorkerWrapper, flagSpec "show-warning-groups" Opt_ShowWarnGroups, - flagSpec "hide-source-paths" Opt_HideSourcePaths + flagSpec "hide-source-paths" Opt_HideSourcePaths, + flagSpec "show-hole-constraints" Opt_ShowHoleConstraints ] -- | These @-f\@ flags can all be reversed with @-fno-\@ diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index a096db2635..1720e4dd54 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -1022,8 +1022,16 @@ mkHoleError ctxt ct@(CHoleCan { cc_hole = hole }) -- Explicit holes, like "_" or "_f" = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct -- The 'False' means "don't filter the bindings"; see Trac #8191 + + ; show_hole_constraints <- goptM Opt_ShowHoleConstraints + ; let constraints_msg + | isExprHoleCt ct, show_hole_constraints + = givenConstraintsMsg ctxt + | otherwise = empty + ; mkErrorMsgFromCt ctxt ct $ - important hole_msg `mappend` relevant_bindings binds_msg } + important hole_msg `mappend` + relevant_bindings (binds_msg $$ constraints_msg) } where occ = holeOcc hole @@ -1070,6 +1078,23 @@ mkHoleError ctxt ct@(CHoleCan { cc_hole = hole }) mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct) + +-- See Note [Constraints include ...] +givenConstraintsMsg :: ReportErrCtxt -> SDoc +givenConstraintsMsg ctxt = + let constraints :: [(Type, RealSrcSpan)] + constraints = + do { Implic{ ic_given = given, ic_env = env } <- cec_encl ctxt + ; constraint <- given + ; return (varType constraint, tcl_loc env) } + + pprConstraint (constraint, loc) = + ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) + + in ppUnless (null constraints) $ + hang (text "Constraints include") + 2 (vcat $ map pprConstraint constraints) + pp_with_type :: OccName -> Type -> SDoc pp_with_type occ ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType ty) @@ -1093,6 +1118,24 @@ mkIPErr ctxt cts (ct1:_) = cts {- +Note [Constraints include ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'givenConstraintsMsg' returns the "Constraints include ..." message enabled by +-fshow-hole-constraints. For example, the following hole: + + foo :: (Eq a, Show a) => a -> String + foo x = _ + +would generate the message: + + Constraints include + Eq a (from foo.hs:1:1-36) + Show a (from foo.hs:1:1-36) + +Constraints are displayed in order from innermost (closest to the hole) to +outermost. There's currently no filtering or elimination of duplicates. + + Note [OutOfScope exact matches] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When constructing an out-of-scope error message, we not only generate a list of diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 912f9aef2f..5db8bdc13b 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -9696,6 +9696,33 @@ Here are some more details: implementation terms, they are reported by the renamer rather than the type checker.) +There's a flag for controlling the amount of context information shown for +typed holes: + +.. ghc-flag:: -fshow-hole-constraints + + When reporting typed holes, also print constraints that are in scope. + Example: :: + + f :: Eq a => a -> Bool + f x = _ + + results in the following message: + + .. code-block:: none + + show_constraints.hs:4:7: error: + • Found hole: _ :: Bool + • In the expression: _ + In an equation for ‘f’: f x = _ + • Relevant bindings include + x :: a (bound at show_constraints.hs:4:3) + f :: a -> Bool (bound at show_constraints.hs:4:1) + Constraints include + Eq a (from the type signature for: + f :: Eq a => a -> Bool + at show_constraints.hs:3:1-22) + .. _partial-type-signatures: diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 8d25b3a55a..a01b018bbe 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -413,6 +413,8 @@ test('T7451', normal, compile, ['']) test('holes', normal, compile, ['-fdefer-type-errors']) test('holes2', normal, compile, ['-fdefer-type-errors']) test('holes3', normal, compile_fail, ['']) +test('hole_constraints', normal, compile, ['-fdefer-type-errors']) +test('hole_constraints_nested', normal, compile, ['-fdefer-type-errors']) test('T7408', normal, compile, ['']) test('UnboxStrictPrimitiveFields', normal, compile, ['']) test('T7541', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_compile/hole_constraints.hs b/testsuite/tests/typecheck/should_compile/hole_constraints.hs new file mode 100644 index 0000000000..dd042f3d33 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/hole_constraints.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fshow-hole-constraints #-} +{-# LANGUAGE GADTs, TypeOperators #-} +module HoleConstraints where +import Data.Type.Equality hiding (castWith) + +-- "from the signature of f1" +f1 :: Eq a => a +f1 = _ + +-- "from the signature of f2", only once +f2 :: (Show a, Eq a) => a +f2 = _ + +-- "from the instance declaration" +class C a where f3 :: a +instance Eq a => C [a] where f3 = _ + +-- "from a pattern with constructor ... in an equation for 'castWith'" +castWith :: a :~: b -> a -> b +castWith Refl x = _ + +data AnyShow where + AnyShow :: Show a => a -> AnyShow + +-- "from a pattern with constructor ... in a case alternative" +foo :: AnyShow -> String +foo a = case a of AnyShow x -> _ diff --git a/testsuite/tests/typecheck/should_compile/hole_constraints.stderr b/testsuite/tests/typecheck/should_compile/hole_constraints.stderr new file mode 100644 index 0000000000..1d49afa706 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/hole_constraints.stderr @@ -0,0 +1,61 @@ + +hole_constraints.hs:8:6: warning: [-Wtyped-holes (in -Wdefault)] + • Found hole: _ :: a + Where: ‘a’ is a rigid type variable bound by + the type signature for: + f1 :: forall a. Eq a => a + at hole_constraints.hs:7:1-15 + • In the expression: _ + In an equation for ‘f1’: f1 = _ + • Relevant bindings include + f1 :: a (bound at hole_constraints.hs:8:1) + Constraints include Eq a (from hole_constraints.hs:7:1-15) + +hole_constraints.hs:12:6: warning: [-Wtyped-holes (in -Wdefault)] + • Found hole: _ :: a + Where: ‘a’ is a rigid type variable bound by + the type signature for: + f2 :: forall a. (Show a, Eq a) => a + at hole_constraints.hs:11:1-25 + • In the expression: _ + In an equation for ‘f2’: f2 = _ + • Relevant bindings include + f2 :: a (bound at hole_constraints.hs:12:1) + Constraints include + Show a (from hole_constraints.hs:11:1-25) + Eq a (from hole_constraints.hs:11:1-25) + +hole_constraints.hs:16:35: warning: [-Wtyped-holes (in -Wdefault)] + • Found hole: _ :: [a] + Where: ‘a’ is a rigid type variable bound by + the instance declaration at hole_constraints.hs:16:10-22 + • In the expression: _ + In an equation for ‘f3’: f3 = _ + In the instance declaration for ‘C [a]’ + • Relevant bindings include + f3 :: [a] (bound at hole_constraints.hs:16:30) + Constraints include Eq a (from hole_constraints.hs:16:10-22) + +hole_constraints.hs:20:19: warning: [-Wtyped-holes (in -Wdefault)] + • Found hole: _ :: b + Where: ‘b’ is a rigid type variable bound by + the type signature for: + castWith :: forall a b. (a :~: b) -> a -> b + at hole_constraints.hs:19:1-29 + • In the expression: _ + In an equation for ‘castWith’: castWith Refl x = _ + • Relevant bindings include + x :: a (bound at hole_constraints.hs:20:15) + castWith :: (a :~: b) -> a -> b (bound at hole_constraints.hs:20:1) + Constraints include b ~ a (from hole_constraints.hs:20:10-13) + +hole_constraints.hs:27:32: warning: [-Wtyped-holes (in -Wdefault)] + • Found hole: _ :: String + • In the expression: _ + In a case alternative: AnyShow x -> _ + In the expression: case a of { AnyShow x -> _ } + • Relevant bindings include + x :: a (bound at hole_constraints.hs:27:27) + a :: AnyShow (bound at hole_constraints.hs:27:5) + foo :: AnyShow -> String (bound at hole_constraints.hs:27:1) + Constraints include Show a (from hole_constraints.hs:27:19-27) diff --git a/testsuite/tests/typecheck/should_compile/hole_constraints_nested.hs b/testsuite/tests/typecheck/should_compile/hole_constraints_nested.hs new file mode 100644 index 0000000000..c8a0a01ca7 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/hole_constraints_nested.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fshow-hole-constraints #-} +{-# LANGUAGE GADTs, TypeOperators #-} +module HoleConstraintsNested where +import Data.Type.Equality + +data EqOrd a where EqOrd :: (Eq a, Ord a) => EqOrd a + +f :: a :~: b -> EqOrd a -> Int +f d1 d2 = + case d1 of + Refl -> case d2 of + EqOrd -> _ diff --git a/testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr b/testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr new file mode 100644 index 0000000000..b41aec8946 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr @@ -0,0 +1,15 @@ + +hole_constraints_nested.hs:12:16: warning: [-Wtyped-holes (in -Wdefault)] + • Found hole: _ :: Int + • In the expression: _ + In a case alternative: EqOrd -> _ + In the expression: case d2 of { EqOrd -> _ } + • Relevant bindings include + d2 :: EqOrd a (bound at hole_constraints_nested.hs:9:6) + d1 :: a :~: b (bound at hole_constraints_nested.hs:9:3) + f :: (a :~: b) -> EqOrd a -> Int + (bound at hole_constraints_nested.hs:9:1) + Constraints include + Eq a (from hole_constraints_nested.hs:12:7-11) + Ord a (from hole_constraints_nested.hs:12:7-11) + b ~ a (from hole_constraints_nested.hs:11:5-8) diff --git a/utils/mkUserGuidePart/Options/Verbosity.hs b/utils/mkUserGuidePart/Options/Verbosity.hs index bbcaf3c8e2..c67fa74b8b 100644 --- a/utils/mkUserGuidePart/Options/Verbosity.hs +++ b/utils/mkUserGuidePart/Options/Verbosity.hs @@ -77,4 +77,8 @@ verbosityOptions = "Summarise timing stats for GHC (same as ``+RTS -tstderr``)." , flagType = DynamicFlag } + , flag { flagName = "-fshow-hole-constraints" + , flagDescription = "Show constraints when reporting typed holes" + , flagType = DynamicFlag + } ] -- GitLab