Implement checkable "minimal complete definitions" (#7633)

This commit adds a `{-# MINIMAL #-}` pragma, which defines the possible
minimal complete definitions for a class. The body of the pragma is a
boolean formula of names.

The old warning for missing methods is replaced with this new one.

Note: The interface file format is changed to store the minimal complete
definition.
Authored-by: Twan van Laarhoven <twanvl@gmail.com>
Signed-off-by: Herbert Valerio Riedel <hvr@gnu.org>

compiler/ghc.cabal.in

@@ -397,6 +397,7 @@ Library
         Unify
         Bag
         Binary
+        BooleanFormula
         BufWrite
         Digraph
         Encoding

compiler/ghc.mk

@@ -446,7 +446,7 @@ compiler_stage3_SplitObjs = NO
 # DLL. This clump are the modules reachable from DynFlags:
 compiler_stage2_dll0_START_MODULE = DynFlags
 
-compiler_stage2_dll0_MODULES =Annotations Avail Bag BasicTypes BinIface Binary Bitmap BlockId BreakArray BufWrite BuildTyCl ByteCodeAsm ByteCodeInstr ByteCodeItbls ByteCodeLink CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreLint CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DynFlags Encoding ErrUtils Exception FamInst FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Finder Fingerprint FiniteMap ForeignCall Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes IOEnv Id IdInfo IfaceEnv IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal LoadIface Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet ObjLink OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelInfo PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcIface TcMType TcRnMonad TcRnTypes TcType TcTypeNats TrieMap TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet
+compiler_stage2_dll0_MODULES = Annotations Avail Bag BasicTypes BinIface Binary Bitmap BlockId BooleanFormula BreakArray BufWrite BuildTyCl ByteCodeAsm ByteCodeInstr ByteCodeItbls ByteCodeLink CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreLint CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DynFlags Encoding ErrUtils Exception FamInst FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Finder Fingerprint FiniteMap ForeignCall Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes IOEnv Id IdInfo IfaceEnv IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal LoadIface Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet ObjLink OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelInfo PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcIface TcMType TcRnMonad TcRnTypes TcType TcTypeNats TrieMap TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet
 
 compiler_stage2_dll0_HS_OBJS = \
     $(patsubst %,compiler/stage2/build/%.$(dyn_osuf),$(subst .,/,$(compiler_stage2_dll0_MODULES)))

compiler/hsSyn/HsBinds.lhs

@@ -30,6 +30,7 @@ import SrcLoc
 import Var
 import Bag
 import FastString
+import BooleanFormula (BooleanFormula)
 
 import Data.Data hiding ( Fixity )
 import Data.List
@@ -559,6 +560,12 @@ data Sig name
         -- (Class tys); should be a specialisation of the
         -- current instance declaration
   | SpecInstSig (LHsType name)
+
+        -- | A minimal complete definition pragma
+        --
+        -- > {-# MINIMAL a | (b, c | (d | e)) #-}
+  | MinimalSig (BooleanFormula (Located name))
+
   deriving (Data, Typeable)
 
 
@@ -631,6 +638,10 @@ isInlineLSig :: LSig name -> Bool
 isInlineLSig (L _ (InlineSig {})) = True
 isInlineLSig _                    = False
 
+isMinimalLSig :: LSig name -> Bool
+isMinimalLSig (L _ (MinimalSig {})) = True
+isMinimalLSig _                    = False
+
 hsSigDoc :: Sig name -> SDoc
 hsSigDoc (TypeSig {})           = ptext (sLit "type signature")
 hsSigDoc (GenericSig {})        = ptext (sLit "default type signature")
@@ -639,6 +650,7 @@ hsSigDoc (SpecSig {})           = ptext (sLit "SPECIALISE pragma")
 hsSigDoc (InlineSig _ prag)     = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma")
 hsSigDoc (SpecInstSig {})       = ptext (sLit "SPECIALISE instance pragma")
 hsSigDoc (FixSig {})            = ptext (sLit "fixity declaration")
+hsSigDoc (MinimalSig {})        = ptext (sLit "MINIMAL pragma")
 \end{code}
 
 Check if signatures overlap; this is used when checking for duplicate
@@ -657,6 +669,7 @@ ppr_sig (FixSig fix_sig)          = ppr fix_sig
 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec (unLoc var) (ppr ty) inl)
 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
+ppr_sig (MinimalSig bf)           = pragBrackets (pprMinimalSig bf)
 
 instance OutputableBndr name => Outputable (FixitySig name) where
   ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)]
@@ -681,4 +694,7 @@ pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)
 
 instance Outputable TcSpecPrag where
   ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
+
+pprMinimalSig :: OutputableBndr name => BooleanFormula (Located name) -> SDoc
+pprMinimalSig bf = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf)
 \end{code}

compiler/iface/BuildTyCl.lhs

@@ -18,7 +18,8 @@ module BuildTyCl (
         TcMethInfo, buildClass,
         distinctAbstractTyConRhs, totallyAbstractTyConRhs,
         mkNewTyConRhs, mkDataTyConRhs, 
-        newImplicitBinder
+        newImplicitBinder,
+        defaultClassMinimalDef
     ) where
 
 #include "HsVersions.h"
@@ -35,6 +36,7 @@ import Class
 import TyCon
 import Type
 import Coercion
+import BooleanFormula( mkAnd, mkVar )
 
 import DynFlags
 import TcRnMonad
@@ -192,10 +194,11 @@ buildClass :: Bool		-- True <=> do not include unfoldings
 	   -> [FunDep TyVar]		   -- Functional dependencies
 	   -> [ClassATItem]		   -- Associated types
 	   -> [TcMethInfo]                 -- Method info
+	   -> ClassMinimalDef              -- Minimal complete definition
 	   -> RecFlag			   -- Info for type constructor
 	   -> TcRnIf m n Class
 
-buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff tc_isrec
+buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
   = fixM  $ \ rec_clas -> 	-- Only name generation inside loop
     do	{ traceIf (text "buildClass")
         ; dflags <- getDynFlags
@@ -271,7 +274,7 @@ buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff tc_isrec
 
 	      ; result = mkClass tvs fds 
 			         sc_theta sc_sel_ids at_items
-				 op_items tycon
+				 op_items mindef tycon
 	      }
 	; traceIf (text "buildClass" <+> ppr tycon) 
 	; return result }
@@ -286,6 +289,14 @@ buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff tc_isrec
                           VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
 			  	          ; return (DefMeth dm_name) }
            ; return (mkDictSelId dflags no_unf op_name rec_clas, dm_info) }
+
+-- by default require all methods without a defaul implementation who's names don't start with '_'
+defaultClassMinimalDef :: [TcMethInfo] -> ClassMinimalDef
+defaultClassMinimalDef meths
+  = mkAnd
+      [ mkVar name
+      | (name, NoDM, _) <- meths
+      , not (startsWithUnderscore (getOccName name)) ]
 \end{code}
 
 Note [Class newtypes and equality predicates]

compiler/iface/IfaceSyn.lhs

@@ -55,6 +55,7 @@ import Module
 import TysWiredIn ( eqTyConName )
 import Fingerprint
 import Binary
+import BooleanFormula ( BooleanFormula )
 
 import Control.Monad
 import System.IO.Unsafe
@@ -103,6 +104,7 @@ data IfaceDecl
                  ifFDs     :: [FunDep FastString], -- Functional dependencies
                  ifATs     :: [IfaceAT],      -- Associated type families
                  ifSigs    :: [IfaceClassOp],   -- Method signatures
+                 ifMinDef  :: BooleanFormula OccName, -- Minimal complete definition
                  ifRec     :: RecFlag           -- Is newtype/datatype associated
                                                 --   with the class recursive?
     }
@@ -155,7 +157,7 @@ instance Binary IfaceDecl where
         put_ bh a4
         put_ bh a5
 
-    put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8) = do
+    put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
         putByte bh 4
         put_ bh a1
         put_ bh (occNameFS a2)
@@ -165,6 +167,7 @@ instance Binary IfaceDecl where
         put_ bh a6
         put_ bh a7
         put_ bh a8
+        put_ bh a9
 
     put_ bh (IfaceAxiom a1 a2 a3 a4) = do
         putByte bh 5
@@ -210,8 +213,9 @@ instance Binary IfaceDecl where
                     a6 <- get bh
                     a7 <- get bh
                     a8 <- get bh
+                    a9 <- get bh
                     occ <- return $! mkOccNameFS clsName a2
-                    return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8)
+                    return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9)
             _ -> do a1 <- get bh
                     a2 <- get bh
                     a3 <- get bh

compiler/iface/MkIface.lhs

@@ -1576,6 +1576,7 @@ classToIfaceDecl env clas
                  ifFDs    = map toIfaceFD clas_fds,
                  ifATs    = map toIfaceAT clas_ats,
                  ifSigs   = map toIfaceClassOp op_stuff,
+                 ifMinDef = fmap getOccName (classMinimalDef clas),
                  ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
   where
     (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff)

compiler/iface/TcIface.lhs

@@ -69,6 +69,7 @@ import FastString
 
 import Control.Monad
 import qualified Data.Map as Map
+import Data.Traversable ( traverse )
 \end{code}
 
 This module takes
@@ -505,7 +506,7 @@ tc_iface_decl _parent ignore_prags
             (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
                          ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds, 
                          ifATs = rdr_ats, ifSigs = rdr_sigs, 
-                         ifRec = tc_isrec })
+                         ifMinDef = mindef_occ, ifRec = tc_isrec })
 -- ToDo: in hs-boot files we should really treat abstract classes specially,
 --       as we do abstract tycons
   = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
@@ -516,10 +517,11 @@ tc_iface_decl _parent ignore_prags
     ; sigs <- mapM tc_sig rdr_sigs
     ; fds  <- mapM tc_fd rdr_fds
     ; traceIf (text "tc-iface-class3" <+> ppr tc_occ)
+    ; mindef <- traverse lookupIfaceTop mindef_occ
     ; cls  <- fixM $ \ cls -> do
               { ats  <- mapM (tc_at cls) rdr_ats
               ; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
-              ; buildClass ignore_prags tc_name tyvars roles ctxt fds ats sigs tc_isrec }
+              ; buildClass ignore_prags tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec }
     ; return (ATyCon (classTyCon cls)) }
   where
    tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)

compiler/parser/Lexer.x

@@ -502,6 +502,7 @@ data Token
   | ITvect_prag
   | ITvect_scalar_prag
   | ITnovect_prag
+  | ITminimal_prag
   | ITctype
 
   | ITdotdot                    -- reserved symbols
@@ -2404,6 +2405,7 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
                            ("ann", token ITann_prag),
                            ("vectorize", token ITvect_prag),
                            ("novectorize", token ITnovect_prag),
+                           ("minimal", token ITminimal_prag),
                            ("ctype", token ITctype)])
 
 twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),

compiler/parser/Parser.y.pp

@@ -41,6 +41,7 @@ import BasicTypes
 import DynFlags
 import OrdList
 import HaddockUtils
+import BooleanFormula   ( BooleanFormula, mkAnd, mkOr, mkTrue, mkVar )
 
 import FastString
 import Maybes           ( orElse )
@@ -266,6 +267,7 @@ incorrect.
  '{-# VECTORISE'          { L _ ITvect_prag }
  '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag }
  '{-# NOVECTORISE'        { L _ ITnovect_prag }
+ '{-# MINIMAL'            { L _ ITminimal_prag }
  '{-# CTYPE'              { L _ ITctype }
  '#-}'                                          { L _ ITclose_prag }
 
@@ -1409,6 +1411,9 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
                             | t <- $5] }
         | '{-# SPECIALISE' 'instance' inst_type '#-}'
                 { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
+        -- A minimal complete definition
+        | '{-# MINIMAL' name_boolformula_opt '#-}'
+                { LL $ unitOL (LL $ SigD (MinimalSig $2)) }
 
 activation :: { Maybe Activation }
         : {- empty -}                           { Nothing }
@@ -1849,6 +1854,22 @@ ipvar   :: { Located HsIPName }
 -----------------------------------------------------------------------------
 -- Warnings and deprecations
 
+name_boolformula_opt :: { BooleanFormula (Located RdrName) }
+        : name_boolformula          { $1 }
+        | {- empty -}               { mkTrue }
+
+name_boolformula :: { BooleanFormula (Located RdrName) }
+        : name_boolformula_and                      { $1 }
+        | name_boolformula_and '|' name_boolformula { mkOr [$1,$3] }
+
+name_boolformula_and :: { BooleanFormula (Located RdrName) }
+        : name_boolformula_atom                             { $1 }
+        | name_boolformula_atom ',' name_boolformula_and    { mkAnd [$1,$3] }
+
+name_boolformula_atom :: { BooleanFormula (Located RdrName) }
+        : '(' name_boolformula ')'  { $2 }
+        | name_var                  { mkVar $1 }
+
 namelist :: { Located [RdrName] }
 namelist : name_var              { L1 [unLoc $1] }
          | name_var ',' namelist { LL (unLoc $1 : unLoc $3) }

compiler/prelude/TysWiredIn.lhs

@@ -103,6 +103,7 @@ import FastString
 import Outputable
 import Config
 import Util
+import BooleanFormula   ( mkAnd )
 
 alpha_tyvar :: [TyVar]
 alpha_tyvar = [alphaTyVar]
@@ -476,7 +477,7 @@ coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon
     args = [a, b]
 
 coercibleClass :: Class
-coercibleClass = mkClass (tyConTyVars coercibleTyCon) [] [] [] [] [] coercibleTyCon
+coercibleClass = mkClass (tyConTyVars coercibleTyCon) [] [] [] [] [] (mkAnd []) coercibleTyCon
 
 \end{code}
 

compiler/rename/RnBinds.lhs

@@ -54,6 +54,7 @@ import FastString
 import Data.List	( partition, sort )
 import Maybes		( orElse )
 import Control.Monad
+import Data.Traversable ( traverse )
 \end{code}
 
 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
@@ -655,7 +656,9 @@ renameSigs :: HsSigCtxt
 -- Renames the signatures and performs error checks
 renameSigs ctxt sigs 
   = do	{ mapM_ dupSigDeclErr (findDupSigs sigs)
-		
+
+	; checkDupMinimalSigs sigs
+
 	; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
 
 	; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
@@ -713,6 +716,10 @@ renameSig ctxt sig@(FixSig (FixitySig v f))
   = do	{ new_v <- lookupSigOccRn ctxt sig v
 	; return (FixSig (FixitySig new_v f), emptyFVs) }
 
+renameSig ctxt sig@(MinimalSig bf)
+  = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
+       return (MinimalSig new_bf, emptyFVs)
+
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
 
@@ -742,6 +749,9 @@ okHsSig ctxt (L _ sig)
      (SpecInstSig {}, InstDeclCtxt {}) -> True
      (SpecInstSig {}, _)               -> False
 
+     (MinimalSig {}, ClsDeclCtxt {}) -> True
+     (MinimalSig {}, _)              -> False
+
 -------------------
 findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]]
 -- Check for duplicates on RdrName version, 
@@ -767,6 +777,13 @@ findDupSigs sigs
     mtch (TypeSig {})    (TypeSig {})    = True
     mtch (GenericSig {}) (GenericSig {}) = True
     mtch _ _ = False
+
+-- Warn about multiple MINIMAL signatures
+checkDupMinimalSigs :: [LSig RdrName] -> RnM ()
+checkDupMinimalSigs sigs
+  = case filter isMinimalLSig sigs of
+      minSigs@(_:_:_) -> dupMinimalSigErr minSigs
+      _ -> return ()
 \end{code}
 
 
@@ -919,4 +936,12 @@ unusedPatBindWarn :: HsBind Name -> SDoc
 unusedPatBindWarn bind
   = hang (ptext (sLit "This pattern-binding binds no variables:"))
        2 (ppr bind)
+
+dupMinimalSigErr :: [LSig RdrName] -> RnM ()
+dupMinimalSigErr sigs@(L loc _ : _)
+  = addErrAt loc $
+    vcat [ ptext (sLit "Multiple minimal complete definitions")
+         , ptext (sLit "at") <+> vcat (map ppr $ sort $ map getLoc sigs)
+         , ptext (sLit "Combine alternative minimal complete definitions with `|'") ]
+dupMinimalSigErr [] = panic "dupMinimalSigErr"
 \end{code}

compiler/typecheck/TcClassDcl.lhs

@@ -15,6 +15,7 @@ Typechecking class declarations
 
 module TcClassDcl ( tcClassSigs, tcClassDecl2, 
 		    findMethodBind, instantiateMethod, tcInstanceMethodBody,
+		    tcClassMinimalDef,
                     HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
 		    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
 		  ) where
@@ -32,7 +33,7 @@ import TcMType
 import Type     ( getClassPredTys_maybe )
 import TcType
 import TcRnMonad
-import BuildTyCl( TcMethInfo )
+import BuildTyCl( TcMethInfo, defaultClassMinimalDef )
 import Class
 import Id
 import Name
@@ -45,6 +46,7 @@ import Maybes
 import BasicTypes
 import Bag
 import FastString
+import BooleanFormula (impliesAtom, isUnsatisfied, pprBooleanFormulaNice)
 import Util
 
 import Control.Monad
@@ -260,6 +262,19 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars
   where
     no_prag_fn  _ = []		-- No pragmas for local_meth_id; 
     		    		-- they are all for meth_id
+
+---------------
+tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
+tcClassMinimalDef _clas sigs op_info
+  = case findMinimalDef sigs of
+      Nothing -> return defMindef
+      Just mindef -> do
+        -- warn if the given mindef does not imply the default one
+        whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
+          warnTc True . warningMinimalDefIncomplete
+        return mindef
+  where
+    defMindef = defaultClassMinimalDef op_info
 \end{code}
 
 \begin{code}
@@ -313,6 +328,13 @@ findMethodBind sel_name binds
              | op_name == sel_name
     	     = Just (bind, bndr_loc)
     f _other = Nothing
+
+---------------------------
+findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
+findMinimalDef = firstJusts . map toMinimalDef
+  where
+    toMinimalDef (L _ (MinimalSig bf)) = Just (fmap unLoc bf)
+    toMinimalDef _ = Nothing
 \end{code}
 
 Note [Polymorphic methods]
@@ -391,4 +413,10 @@ badDmPrag sel_id prag
   = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method") 
               <+> quotes (ppr sel_id) 
               <+> ptext (sLit "lacks an accompanying binding"))
+
+warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
+warningMinimalDefIncomplete mindef
+  = vcat [ ptext (sLit "The MINIMAL pragma does not require:")
+         , nest 2 (pprBooleanFormulaNice mindef)
+         , ptext (sLit "but there is no default implementation.") ]
 \end{code}

compiler/typecheck/TcInstDcls.lhs

@@ -66,9 +66,10 @@ import NameSet
 import Outputable
 import SrcLoc
 import Util
+import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
 
 import Control.Monad
-import Maybes     ( orElse, isNothing )
+import Maybes     ( orElse, isNothing, isJust, whenIsJust )
 \end{code}
 
 Typechecking instance declarations is done in two passes. The first
@@ -1175,6 +1176,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                   op_items (VanillaInst binds sigs standalone_deriv)
   = do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
        ; let hs_sig_fn = mkHsSigFun sigs
+       ; checkMinimalDefinition
        ; mapAndUnzipM (tc_item hs_sig_fn) op_items }
   where
     ----------------------
@@ -1215,7 +1217,6 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
     tc_default sig_fn sel_id NoDefMeth     -- No default method at all
       = do { traceTc "tc_def: warn" (ppr sel_id)
-           ; warnMissingMethodOrAT "method" (idName sel_id)
            ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
                                        inst_tys sel_id
            ; dflags <- getDynFlags
@@ -1300,6 +1301,15 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
       | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
       | otherwise      = thing
 
+    ----------------------
+
+    -- check if one of the minimal complete definitions is satisfied
+    checkMinimalDefinition
+      = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
+          warnUnsatisifiedMinimalDefinition
+      where
+      methodExists meth = isJust (findMethodBind meth binds)
+
 
 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                   _ op_items (NewTypeDerived coi _)
@@ -1410,6 +1420,16 @@ warnMissingMethodOrAT what name
                                         -- Don't warn about _foo methods
                 (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for")
                  <+> quotes (ppr name)) }
+
+warnUnsatisifiedMinimalDefinition :: ClassMinimalDef -> TcM ()
+warnUnsatisifiedMinimalDefinition mindef
+  = do { warn <- woptM Opt_WarnMissingMethods
+       ; warnTc warn message
+       }
+  where
+    message = vcat [ptext (sLit "No explicit implementation for")
+                   ,nest 2 $ pprBooleanFormulaNice mindef
+                   ]
 \end{code}
 
 Note [Export helper functions]

compiler/typecheck/TcTyClsDecls.lhs

@@ -620,9 +620,10 @@ tcTyClDecl1 _parent rec_info
                ; fds'  <- mapM (addLocM tc_fundep) fundeps
                ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
                ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs
+               ; mindef <- tcClassMinimalDef class_name sigs sig_stuff
                ; clas <- buildClass False {- Must include unfoldings for selectors -}
                             class_name tvs' roles ctxt' fds' at_stuff
-                            sig_stuff tc_isrec
+                            sig_stuff mindef tc_isrec
                ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds')
                ; return (clas, tvs', gen_dm_env) }
 

compiler/types/Class.lhs

@@ -17,6 +17,7 @@ module Class (
 	Class,
         ClassOpItem, DefMeth (..),
         ClassATItem,
+        ClassMinimalDef,
 	defMethSpecOfDefMeth,
 
 	FunDep,	pprFundeps, pprFunDep,
@@ -24,7 +25,7 @@ module Class (
 	mkClass, classTyVars, classArity, 
 	classKey, className, classATs, classATItems, classTyCon, classMethods,
 	classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
-        classAllSelIds, classSCSelId
+        classAllSelIds, classSCSelId, classMinimalDef
     ) where
 
 #include "Typeable.h"
@@ -40,6 +41,7 @@ import Unique
 import Util
 import Outputable
 import FastString
+import BooleanFormula (BooleanFormula)
 
 import Data.Typeable (Typeable)
 import qualified Data.Data as Data
@@ -79,7 +81,10 @@ data Class
         classATStuff :: [ClassATItem],	-- Associated type families
 
         -- Class operations (methods, not superclasses)
-	classOpStuff :: [ClassOpItem]	-- Ordered by tag
+	classOpStuff :: [ClassOpItem],	-- Ordered by tag
+
+	-- Minimal complete definition
+	classMinimalDef :: ClassMinimalDef
      }
   deriving Typeable
 
@@ -100,6 +105,8 @@ type ClassATItem = (TyCon,           -- See Note [Associated type tyvar names]
   -- We can have more than one default per type; see
   -- Note [Associated type defaults] in TcTyClsDecls
 
+type ClassMinimalDef = BooleanFormula Name -- Required methods
+
 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
 --   the `DefMeth` constructor of the `DefMeth`.
 defMethSpecOfDefMeth :: DefMeth -> DefMethSpec
@@ -115,24 +122,26 @@ The @mkClass@ function fills in the indirect superclasses.
 
 \begin{code}
 mkClass :: [TyVar]
-	-> [([TyVar], [TyVar])]
-	-> [PredType] -> [Id]
-	-> [ClassATItem]
-	-> [ClassOpItem]
-	-> TyCon
-	-> Class
+        -> [([TyVar], [TyVar])]
+        -> [PredType] -> [Id]
+        -> [ClassATItem]
+        -> [ClassOpItem]
+        -> ClassMinimalDef
+        -> TyCon
+        -> Class
 
 mkClass tyvars fds super_classes superdict_sels at_stuff
-	op_stuff tycon
-  = Class {	classKey     = tyConUnique tycon, 
-		className    = tyConName tycon,
-		classTyVars  = tyvars,
-		classFunDeps = fds,
-		classSCTheta = super_classes,
-		classSCSels  = superdict_sels,
-		classATStuff = at_stuff,
-		classOpStuff = op_stuff,
-		classTyCon   = tycon }
+        op_stuff mindef tycon
+  = Class { classKey     = tyConUnique tycon,
+            className    = tyConName tycon,
+            classTyVars  = tyvars,
+            classFunDeps = fds,
+            classSCTheta = super_classes,
+            classSCSels  = superdict_sels,
+            classATStuff = at_stuff,
+            classOpStuff = op_stuff,
+            classMinimalDef = mindef,
+            classTyCon   = tycon }
 \end{code}
 
 Note [Associated type tyvar names]

compiler/utils/BooleanFormula.hs

+--------------------------------------------------------------------------------
+-- | Boolean formulas without negation (qunatifier free)
+
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,
+             DeriveTraversable #-}
+
+module BooleanFormula (
+        BooleanFormula(..),
+        mkFalse, mkTrue, mkAnd, mkOr, mkVar,
+        isFalse, isTrue,
+        eval, simplify, isUnsatisfied,
+        implies, impliesAtom,
+        pprBooleanFormula, pprBooleanFormulaNice
+  ) where
+
+import Data.List ( nub, intersperse )
+import Data.Data
+import Data.Foldable ( Foldable )
+import Data.Traversable ( Traversable )
+
+import MonadUtils
+import Outputable
+import Binary
+
+----------------------------------------------------------------------
+-- Boolean formula type and smart constructors
+----------------------------------------------------------------------
+
+data BooleanFormula a = Var a | And [BooleanFormula a] | Or [BooleanFormula a]
+  deriving (Eq, Data, Typeable, Functor, Foldable, Traversable)
+
+mkVar :: a -> BooleanFormula a
+mkVar = Var
+
+mkFalse, mkTrue :: BooleanFormula a
+mkFalse = Or []
+mkTrue = And []
+
+mkBool :: Bool -> BooleanFormula a
+mkBool False = mkFalse
+mkBool True  = mkTrue
+
+mkAnd :: Eq a => [BooleanFormula a] -> BooleanFormula a
+mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd
+  where
+  fromAnd :: BooleanFormula a -> Maybe [BooleanFormula a]
+  fromAnd (And xs) = Just xs
+     -- assume that xs are already simplified
+     -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs
+  fromAnd (Or []) = Nothing -- in case of False we bail out, And [..,mkFalse,..] == mkFalse
+  fromAnd x = Just [x]
+  mkAnd' [x] = x
+  mkAnd' xs = And xs
+
+mkOr :: Eq a => [BooleanFormula a] -> BooleanFormula a
+mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr
+  where
+  fromOr (Or xs) = Just xs
+  fromOr (And []) = Nothing
+  fromOr x = Just [x]
+  mkOr' [x] = x
+  mkOr' xs = Or xs
+
+----------------------------------------------------------------------
+-- Evaluation and simplificiation
+----------------------------------------------------------------------
+
+isFalse :: BooleanFormula a -> Bool
+isFalse (Or []) = True
+isFalse _ = False
+
+isTrue :: BooleanFormula a -> Bool
+isTrue (And []) = True
+isTrue _ = False
+
+eval :: (a -> Bool) -> BooleanFormula a -> Bool
+eval f (Var x)  = f x
+eval f (And xs) = all (eval f) xs
+eval f (Or xs)  = any (eval f) xs
+
+-- Simplify a boolean formula.
+-- The argument function should give the truth of the atoms, or Nothing if undecided.
+simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a
+simplify f (Var a) = case f a of
+  Nothing -> Var a
+  Just b  -> mkBool b
+simplify f (And xs) = mkAnd (map (simplify f) xs)