summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/ghc.mk2
-rw-r--r--compiler/hsSyn/HsBinds.lhs16
-rw-r--r--compiler/iface/BuildTyCl.lhs17
-rw-r--r--compiler/iface/IfaceSyn.lhs8
-rw-r--r--compiler/iface/MkIface.lhs1
-rw-r--r--compiler/iface/TcIface.lhs6
-rw-r--r--compiler/parser/Lexer.x2
-rw-r--r--compiler/parser/Parser.y.pp21
-rw-r--r--compiler/prelude/TysWiredIn.lhs3
-rw-r--r--compiler/rename/RnBinds.lhs27
-rw-r--r--compiler/typecheck/TcClassDcl.lhs30
-rw-r--r--compiler/typecheck/TcInstDcls.lhs24
-rw-r--r--compiler/typecheck/TcTyClsDecls.lhs3
-rw-r--r--compiler/types/Class.lhs45
-rw-r--r--compiler/utils/BooleanFormula.hs167
-rw-r--r--compiler/vectorise/Vectorise/Type/TyConDecl.hs1
-rw-r--r--docs/users_guide/glasgow_exts.xml30
-rw-r--r--docs/users_guide/using.xml1
19 files changed, 373 insertions, 32 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 553d27d2ba..a4e40d80fb 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -397,6 +397,7 @@ Library
Unify
Bag
Binary
+ BooleanFormula
BufWrite
Digraph
Encoding
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 66548b67da..b319ec649a 100644
--- a/compiler/ghc.mk
+++ b/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)))
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index db4c177b90..139f5bf118 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/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}
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 20aea22e47..024c4190c8 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/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]
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index c82973f997..dec4b3608e 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/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
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 80b83f197e..9143b294a2 100644
--- a/compiler/iface/MkIface.lhs
+++ b/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)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 38043c6454..564189413a 100644
--- a/compiler/iface/TcIface.lhs
+++ b/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)
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 344281ad49..41ba1d849a 100644
--- a/compiler/parser/Lexer.x
+++ b/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)),
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 0ea48dd557..2b734cad41 100644
--- a/compiler/parser/Parser.y.pp
+++ b/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) }
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 443c09cf1e..d795c32175 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/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}
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 81e9316fa9..c30760d7ad 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/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}
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 06ddc4ef1d..b7beffee02 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/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}
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 9962a0bf1d..65c8f2dafd 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/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]
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 988d6338f1..93568f4fc4 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/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) }
diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 7a1251f8ea..c81f0ac6b4 100644
--- a/compiler/types/Class.lhs
+++ b/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]
diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs
new file mode 100644
index 0000000000..3e82e75b1f
--- /dev/null
+++ b/compiler/utils/BooleanFormula.hs
@@ -0,0 +1,167 @@
+--------------------------------------------------------------------------------
+-- | 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)
+simplify f (Or xs) = mkOr (map (simplify f) xs)
+
+-- Test if a boolean formula is satisfied when the given values are assigned to the atoms
+-- if it is, returns Nothing
+-- if it is not, return (Just remainder)
+isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)
+isUnsatisfied f bf
+ | isTrue bf' = Nothing
+ | otherwise = Just bf'
+ where
+ f' x = if f x then Just True else Nothing
+ bf' = simplify f' bf
+
+-- prop_simplify:
+-- eval f x == True <==> isTrue (simplify (Just . f) x)
+-- eval f x == False <==> isFalse (simplify (Just . f) x)
+
+-- If the boolean formula holds, does that mean that the given atom is always true?
+impliesAtom :: Eq a => BooleanFormula a -> a -> Bool
+Var x `impliesAtom` y = x == y
+And xs `impliesAtom` y = any (`impliesAtom` y) xs -- we have all of xs, so one of them implying y is enough
+Or xs `impliesAtom` y = all (`impliesAtom` y) xs
+
+implies :: Eq a => BooleanFormula a -> BooleanFormula a -> Bool
+x `implies` Var y = x `impliesAtom` y
+x `implies` And ys = all (x `implies`) ys
+x `implies` Or ys = any (x `implies`) ys
+
+----------------------------------------------------------------------
+-- Pretty printing
+----------------------------------------------------------------------
+
+pprBooleanFormula' :: (Rational -> a -> SDoc)
+ -> (Rational -> [SDoc] -> SDoc)
+ -> (Rational -> [SDoc] -> SDoc)
+ -> Rational -> BooleanFormula a -> SDoc
+pprBooleanFormula' pprVar pprAnd pprOr = go
+ where
+ go p (Var x) = pprVar p x
+ go p (And []) = cparen (p > 0) $ empty
+ go p (And xs) = pprAnd p (map (go 3) xs)
+ go _ (Or []) = keyword $ text "FALSE"
+ go p (Or xs) = pprOr p (map (go 2) xs)
+
+-- Pretty print in source syntax, "a | b | c,d,e"
+pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc
+pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr
+ where
+ pprAnd p = cparen (p > 3) . fsep . punctuate comma
+ pprOr p = cparen (p > 2) . fsep . intersperse (text "|")
+
+-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"?
+pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc
+pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0
+ where
+ pprVar _ = quotes . ppr
+ pprAnd p = cparen (p > 1) . pprAnd'
+ pprAnd' [] = empty
+ pprAnd' [x,y] = x <+> text "and" <+> y
+ pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs
+ pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs)
+
+instance Outputable a => Outputable (BooleanFormula a) where
+ pprPrec = pprBooleanFormula pprPrec
+
+----------------------------------------------------------------------
+-- Binary
+----------------------------------------------------------------------
+
+instance Binary a => Binary (BooleanFormula a) where
+ put_ bh (Var x) = putByte bh 0 >> put_ bh x
+ put_ bh (And xs) = putByte bh 1 >> put_ bh xs
+ put_ bh (Or xs) = putByte bh 2 >> put_ bh xs
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> Var <$> get bh
+ 1 -> And <$> get bh
+ _ -> Or <$> get bh
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 935ea32c69..29d54a074b 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -67,6 +67,7 @@ vectTyConDecl tycon name'
(snd . classTvsFds $ cls) -- keep the original functional dependencies
[] -- no associated types (for the moment)
methods' -- method info
+ (defaultClassMinimalDef methods') -- default minimal complete definition
rec_flag -- whether recursive
-- the original dictionary constructor must map to the vectorised one
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index b49ad9fd70..4390f535ca 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -9181,6 +9181,36 @@ Assertion failures can be caught, see the documentation for the
<option>-fno-warn-warnings-deprecations</option>.</para>
</sect2>
+ <sect2 id="minimal-pragma">
+ <title>MINIMAL pragma</title>
+ <indexterm><primary>MINIMAL</primary></indexterm>
+ <para>The MINIMAL pragma is used to specify the minimal complete definition of a class. I.e. specify which methods must be implemented by all instances. If an instance does not satisfy the minimal complete definition, then a warning is generated.
+ This can be useful when a class has methods with circular defaults. For example
+ </para>
+<programlisting>
+class Eq a where
+ (==) :: a -> a -> Bool
+ (/=) :: a -> a -> Bool
+ x == y = not (x /= y)
+ x /= y = not (x == y)
+ {-# MINIMAL (==) | (/=) #-}
+</programlisting>
+ <para>Without the MINIMAL pragma no warning would be generated for an instance that implements neither method.
+ </para>
+ <para>The syntax for minimal complete definition is:</para>
+<screen>
+mindef ::= name
+ | '(' mindef ')'
+ | mindef '|' mindef
+ | mindef ',' mindef
+</screen>
+ <para>A vertical bar denotes disjunction, i.e. one of the two sides is required.
+ A comma denotes conjunction, i.e. both sides are required.
+ Conjunction binds stronger than disjunction.</para>
+ <para>If no MINIMAL pragma is used, then all methods without a default will be requried, excluding methods with a name that starts with an underscore.</para>
+ <para>This warning can be turned off with the flag <option>-fno-warn-missing-methods</option>.</para>
+ </sect2>
+
<sect2 id="inline-noinline-pragma">
<title>INLINE and NOINLINE pragmas</title>
diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index c2b4a17eb8..8ac2779b2d 100644
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -1509,6 +1509,7 @@ module M where
never <literal>_simpleFn</literal>; and (b)
instance declarations can define either <literal>complexFn</literal> or <literal>_simpleFn</literal>.
</para>
+ <para>The MINIMAL pragma can be used to change which combination of methods will be required for instances of a particular class. See <xref linkend="minimal-pragma"/>.</para>
</listitem>
</varlistentry>
View Lorry Controller Status