Commit bd42c9df authored by twanvl's avatar twanvl Committed by Herbert Valerio Riedel
Browse files

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: twanvl's avatarTwan van Laarhoven <twanvl@gmail.com>
Signed-off-by: Herbert Valerio Riedel's avatarHerbert Valerio Riedel <hvr@gnu.org>
parent b6bc3263
......@@ -397,6 +397,7 @@ Library
Unify
Bag
Binary
BooleanFormula
BufWrite
Digraph
Encoding
......
......@@ -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)))
......
......@@ -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}
......@@ -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]
......
......@@ -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
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)),
......
......@@ -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) }
......
......@@ -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}
......
......@@ -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}
......@@ -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}
......@@ -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]
......
......@@ -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) }
......
......@@ -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]
......
--------------------------------------------------------------------------------
-- | 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