From 43eb1dc52a4d3cbba9617f5a26177b8251d84b6a Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Thu, 17 Sep 2015 16:02:06 +0200 Subject: [PATCH] Show minimal complete definitions in ghci (#10847) Show the minimal complete definition on :info in ghci. They are shown like MINIMAL pragmas in code. If the minimal complete definition is empty or only a specific method from a class is requested, nothing is shown. Reviewed By: simonpj, austin, thomie Differential Revision: https://phabricator.haskell.org/D1241 --- compiler/iface/IfaceSyn.hs | 30 +++++++++++++++++-- .../tests/driver/sigof01/sigof01i2.stdout | 1 + .../tests/ghci/prog008/ghci.prog008.stdout | 2 ++ testsuite/tests/ghci/scripts/T9181.stdout | 2 ++ testsuite/tests/ghci/scripts/ghci008.stdout | 3 ++ testsuite/tests/ghci/scripts/ghci025.stdout | 5 ++++ .../indexed-types/should_compile/T3017.stderr | 1 + .../tests/rename/should_fail/rnfail055.stderr | 2 ++ .../tests/roles/should_compile/Roles14.stderr | 1 + .../tests/roles/should_compile/Roles3.stderr | 4 +++ .../tests/roles/should_compile/Roles4.stderr | 2 ++ .../typecheck/should_compile/tc231.stderr | 1 + 12 files changed, 51 insertions(+), 3 deletions(-) diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 6371c43b0e..61ec33e56c 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -53,13 +53,14 @@ import Module import SrcLoc import Fingerprint import Binary -import BooleanFormula ( BooleanFormula ) +import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import HsBinds import TyCon ( Role (..), Injectivity(..) ) import StaticFlags (opt_PprStyle_Debug) import Util( filterOut, filterByList ) import InstEnv import DataCon (SrcStrictness(..), SrcUnpackedness(..)) +import Lexeme (isLexSym) import Control.Monad import System.IO.Unsafe @@ -529,6 +530,15 @@ instance HasOccName IfaceDecl where instance Outputable IfaceDecl where ppr = pprIfaceDecl showAll +{- +Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The minimal complete definition should only be included if a complete +class definition is shown. Since the minimal complete definition is +anonymous we can't reuse the same mechanism that is used for the +filtering of method signatures. Instead we just check if anything at all is +filtered and hide it in that case. +-} + data ShowSub = ShowSub { ss_ppr_bndr :: OccName -> SDoc -- Pretty-printer for binders in IfaceDecl @@ -550,6 +560,12 @@ ppShowIface :: ShowSub -> SDoc -> SDoc ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc ppShowIface _ _ = Outputable.empty +-- show if all sub-components or the complete interface is shown +ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition] +ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] }) doc = doc +ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowAllSubs _ _ = Outputable.empty + ppShowRhs :: ShowSub -> SDoc -> SDoc ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _ = Outputable.empty ppShowRhs _ doc = doc @@ -662,11 +678,12 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec , ifCtxt = context, ifName = clas , ifTyVars = tyvars, ifRoles = roles - , ifFDs = fds }) + , ifFDs = fds, ifMinDef = minDef }) = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) tyvars roles , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas tyvars <+> pprFundeps fds <+> pp_where - , nest 2 (vcat [vcat asocs, vcat dsigs, pprec])] + , nest 2 (vcat [ vcat asocs, vcat dsigs, pprec + , ppShowAllSubs ss (pprMinDef minDef)])] where pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (ptext (sLit "where")) @@ -684,6 +701,13 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec | showSub ss sg = Just $ pprIfaceClassOp ss sg | otherwise = Nothing + pprMinDef :: BooleanFormula IfLclName -> SDoc + pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions + ptext (sLit "{-# MINIMAL") <+> + pprBooleanFormula + (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> + ptext (sLit "#-}") + pprIfaceDecl ss (IfaceSynonym { ifName = tc , ifTyVars = tv , ifSynRhs = mono_ty }) diff --git a/testsuite/tests/driver/sigof01/sigof01i2.stdout b/testsuite/tests/driver/sigof01/sigof01i2.stdout index ac15dcfa1e..1ee81c10d2 100644 --- a/testsuite/tests/driver/sigof01/sigof01i2.stdout +++ b/testsuite/tests/driver/sigof01/sigof01i2.stdout @@ -1,5 +1,6 @@ class Foo a where foo :: a -> a + {-# MINIMAL foo #-} data T = A.T mkT :: T x :: Bool diff --git a/testsuite/tests/ghci/prog008/ghci.prog008.stdout b/testsuite/tests/ghci/prog008/ghci.prog008.stdout index 99e63a1b14..df6767bb84 100644 --- a/testsuite/tests/ghci/prog008/ghci.prog008.stdout +++ b/testsuite/tests/ghci/prog008/ghci.prog008.stdout @@ -2,7 +2,9 @@ class C a b where c1 :: Num b => a -> b c2 :: (Num b, Show b) => a -> b c3 :: a1 -> b + {-# MINIMAL c1, c2, c3 #-} class C a b where c1 :: Num b => a -> b c2 :: (Num b, Show b) => a -> b c3 :: forall a1. a1 -> b + {-# MINIMAL c1, c2, c3 #-} \ No newline at end of file diff --git a/testsuite/tests/ghci/scripts/T9181.stdout b/testsuite/tests/ghci/scripts/T9181.stdout index 7e8b95af80..3ea130d177 100644 --- a/testsuite/tests/ghci/scripts/T9181.stdout +++ b/testsuite/tests/ghci/scripts/T9181.stdout @@ -7,8 +7,10 @@ type family CmpNat (a :: Nat) (b :: Nat) :: Ordering type family CmpSymbol (a :: Symbol) (b :: Symbol) :: Ordering class KnownNat (n :: Nat) where natSing :: SNat n + {-# MINIMAL natSing #-} class KnownSymbol (n :: Symbol) where symbolSing :: SSymbol n + {-# MINIMAL symbolSing #-} data SomeNat where SomeNat :: KnownNat n => (Proxy n) -> SomeNat data SomeSymbol where diff --git a/testsuite/tests/ghci/scripts/ghci008.stdout b/testsuite/tests/ghci/scripts/ghci008.stdout index 9a1bcf7551..eb057ca4bd 100644 --- a/testsuite/tests/ghci/scripts/ghci008.stdout +++ b/testsuite/tests/ghci/scripts/ghci008.stdout @@ -27,6 +27,9 @@ class (RealFrac a, Floating a) => RealFloat a where isNegativeZero :: a -> Bool isIEEE :: a -> Bool atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, + encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, + isIEEE #-} -- Defined in ‘GHC.Float’ instance RealFloat Float -- Defined in ‘GHC.Float’ instance RealFloat Double -- Defined in ‘GHC.Float’ diff --git a/testsuite/tests/ghci/scripts/ghci025.stdout b/testsuite/tests/ghci/scripts/ghci025.stdout index e5b5bc34b7..fc9bd6e2b1 100644 --- a/testsuite/tests/ghci/scripts/ghci025.stdout +++ b/testsuite/tests/ghci/scripts/ghci025.stdout @@ -9,6 +9,7 @@ class C a b where c2 :: (N b, S b) => a -> b c3 :: a1 -> b c4 :: a1 -> b + {-# MINIMAL c1, c2, c3, c4 #-} c1 :: (C a b, N b) => a -> b c2 :: (C a b, N b, S b) => a -> b c3 :: C a b => forall a. a -> b @@ -30,6 +31,7 @@ class Applicative m => Monad (m :: * -> *) where (>>) :: m a -> m b -> m b return :: a -> m a fail :: String -> m a + {-# MINIMAL (>>=) #-} -- imported via Data.Maybe catMaybes :: [Maybe a] -> [a] fromJust :: Maybe a -> a @@ -50,6 +52,7 @@ Nothing :: Maybe a class Eq a where (==) :: a -> a -> Bool (/=) :: a -> a -> Bool + {-# MINIMAL (==) | (/=) #-} -- imported via Prelude, T Prelude.length :: Foldable t => forall a. t a -> Int -- imported via T @@ -68,6 +71,7 @@ class C a b where c2 :: (N b, S b) => a -> b c3 :: a1 -> b c4 :: a1 -> b + {-# MINIMAL c1, c2, c3, c4 #-} c1 :: (C a b, N b) => a -> b c2 :: (C a b, N b, S b) => a -> b c3 :: C a b => forall a. a -> b @@ -82,6 +86,7 @@ class C a b where c2 :: (N b, S b) => a -> b c3 :: forall a1. a1 -> b c4 :: forall a1. a1 -> b + {-# MINIMAL c1, c2, c3, c4 #-} c1 :: forall a b. (C a b, N b) => a -> b c2 :: forall a b. (C a b, N b, S b) => a -> b c3 :: forall a b. C a b => forall a. a -> b diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr index cffbf700a6..2d2187c5a7 100644 --- a/testsuite/tests/indexed-types/should_compile/T3017.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr @@ -7,6 +7,7 @@ TYPE CONSTRUCTORS type family Elem c :: * open empty :: c insert :: Elem c -> c -> c + {-# MINIMAL empty, insert #-} data ListColl a = L [a] Promotable COERCION AXIOMS diff --git a/testsuite/tests/rename/should_fail/rnfail055.stderr b/testsuite/tests/rename/should_fail/rnfail055.stderr index 4611e867ec..d87054e926 100644 --- a/testsuite/tests/rename/should_fail/rnfail055.stderr +++ b/testsuite/tests/rename/should_fail/rnfail055.stderr @@ -87,8 +87,10 @@ RnFail055.hs-boot:28:1: error: Main module: class C2 a b where m2 :: a -> b m2' :: a -> b + {-# MINIMAL m2, m2' #-} Boot file: class C2 a b where m2 :: a -> b + {-# MINIMAL m2 #-} The methods do not match: There are different numbers of methods RnFail055.hs-boot:29:1: error: diff --git a/testsuite/tests/roles/should_compile/Roles14.stderr b/testsuite/tests/roles/should_compile/Roles14.stderr index 230603cf09..bb61133ce0 100644 --- a/testsuite/tests/roles/should_compile/Roles14.stderr +++ b/testsuite/tests/roles/should_compile/Roles14.stderr @@ -3,6 +3,7 @@ TYPE CONSTRUCTORS type role C2 representational class C2 a where meth2 :: a -> a + {-# MINIMAL meth2 #-} COERCION AXIOMS axiom Roles12.NTCo:C2 :: C2 a = a -> a Dependent modules: [] diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr index 93cafc0c94..6f25b63691 100644 --- a/testsuite/tests/roles/should_compile/Roles3.stderr +++ b/testsuite/tests/roles/should_compile/Roles3.stderr @@ -2,13 +2,17 @@ TYPE SIGNATURES TYPE CONSTRUCTORS class C1 a where meth1 :: a -> a + {-# MINIMAL meth1 #-} class C2 a b where meth2 :: a ~ b => a -> b + {-# MINIMAL meth2 #-} class C3 a b where type family F3 b :: * open meth3 :: a -> F3 b -> F3 b + {-# MINIMAL meth3 #-} class C4 a b where meth4 :: a -> F4 b -> F4 b + {-# MINIMAL meth4 #-} type family F4 a :: * open type Syn1 a = F4 a type Syn2 a = [a] diff --git a/testsuite/tests/roles/should_compile/Roles4.stderr b/testsuite/tests/roles/should_compile/Roles4.stderr index 109a2bb96f..0113869e42 100644 --- a/testsuite/tests/roles/should_compile/Roles4.stderr +++ b/testsuite/tests/roles/should_compile/Roles4.stderr @@ -2,8 +2,10 @@ TYPE SIGNATURES TYPE CONSTRUCTORS class C1 a where meth1 :: a -> a + {-# MINIMAL meth1 #-} class C3 a where meth3 :: a -> Syn1 a + {-# MINIMAL meth3 #-} type Syn1 a = [a] COERCION AXIOMS axiom Roles4.NTCo:C1 :: C1 a = a -> a diff --git a/testsuite/tests/typecheck/should_compile/tc231.stderr b/testsuite/tests/typecheck/should_compile/tc231.stderr index fb011c66c5..5503eaf295 100644 --- a/testsuite/tests/typecheck/should_compile/tc231.stderr +++ b/testsuite/tests/typecheck/should_compile/tc231.stderr @@ -11,6 +11,7 @@ TYPE CONSTRUCTORS Promotable class Zork s a b | a -> b where huh :: Q s a chain -> ST s () + {-# MINIMAL huh #-} COERCION AXIOMS axiom NTCo:Zork :: Zork s a b = forall chain. Q s a chain -> ST s () -- GitLab