Commit 75a9664a authored by Austin Seipp's avatar Austin Seipp
Browse files

Implement the AMP warning (#8004)

This patch implements a warning when definitions conflict with the
Applicative-Monad Proposal (AMP), described in #8004

. Namely, this will
cause a warning iff:

    * You have an instance of Monad, but not Applicative
    * You have an instance of MonadPlus, but not Alternative
    * You locally defined a function named join, <*>, or pure.

In GHC 7.10, these warnings will actually be enforced with superclass
constraints through changes in base, so programs will fail to compile
then.

This warning is enabled by default. Unfortunately, not all of
our upstream libraries have accepted the appropriate patches. So we
temporarily fix ./validate by ignoring the AMP warning.

Dan Rosén made an initial implementation of this change, and the
remaining work was finished off by David Luposchainsky. I finally made
some minor refactorings.
Authored-by: danr's avatarDan Rosén <danr@chalmers.se>
Authored-by: quchen's avatarDavid Luposchainsky <dluposchainsky@gmail.com>
Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent b20cf4ec
......@@ -433,6 +433,7 @@ data WarningFlag =
| Opt_WarnUnusedMatches
| Opt_WarnWarningsDeprecations
| Opt_WarnDeprecatedFlags
| Opt_WarnAMP
| Opt_WarnDodgyExports
| Opt_WarnDodgyImports
| Opt_WarnOrphans
......@@ -2503,6 +2504,7 @@ fWarningFlags = [
( "warn-warnings-deprecations", Opt_WarnWarningsDeprecations, nop ),
( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ),
( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ),
( "warn-amp", Opt_WarnAMP, nop ),
( "warn-orphans", Opt_WarnOrphans, nop ),
( "warn-identities", Opt_WarnIdentities, nop ),
( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ),
......@@ -2916,6 +2918,7 @@ standardWarnings
= [ Opt_WarnOverlappingPatterns,
Opt_WarnWarningsDeprecations,
Opt_WarnDeprecatedFlags,
Opt_WarnAMP,
Opt_WarnUnrecognisedPragmas,
Opt_WarnPointlessPragmas,
Opt_WarnDuplicateConstraints,
......
......@@ -184,6 +184,7 @@ basicKnownKeyNames
dataClassName,
isStringClassName,
applicativeClassName,
alternativeClassName,
foldableClassName,
traversableClassName,
typeableClassName, -- derivable
......@@ -203,10 +204,15 @@ basicKnownKeyNames
enumFromName, enumFromThenName,
enumFromThenToName, enumFromToName,
-- Applicative/Alternative stuff
pureAName,
apAName,
-- Monad stuff
thenIOName, bindIOName, returnIOName, failIOName,
failMName, bindMName, thenMName, returnMName,
fmapName,
joinMName,
-- MonadRec stuff
mfixName,
......@@ -701,8 +707,8 @@ notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR,
traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap")
pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure")
ap_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "<*>")
pure_RDR = nameRdrName pureAName
ap_RDR = nameRdrName apAName
foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr")
foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap")
traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse")
......@@ -821,6 +827,24 @@ applicativeClassName = clsQual cONTROL_APPLICATIVE (fsLit "Applicative") appli
foldableClassName = clsQual dATA_FOLDABLE (fsLit "Foldable") foldableClassKey
traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") traversableClassKey
-- AMP additions
joinMName, apAName, pureAName, alternativeClassName :: Name
joinMName = methName mONAD (fsLit "join") joinMIdKey
apAName = methName cONTROL_APPLICATIVE (fsLit "<*>") apAClassOpKey
pureAName = methName cONTROL_APPLICATIVE (fsLit "pure") pureAClassOpKey
alternativeClassName = clsQual cONTROL_APPLICATIVE (fsLit "Alternative") alternativeClassKey
joinMIdKey, apAClassOpKey, pureAClassOpKey, alternativeClassKey :: Unique
joinMIdKey = mkPreludeMiscIdUnique 750
apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*>
pureAClassOpKey = mkPreludeMiscIdUnique 752
alternativeClassKey = mkPreludeMiscIdUnique 753
-- Functions for GHC extensions
groupWithName :: Name
groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
......@@ -1812,7 +1836,8 @@ standardClassKeys = derivableClassKeys ++ numericClassKeys
functorClassKey,
monadClassKey, monadPlusClassKey,
isStringClassKey,
applicativeClassKey, foldableClassKey, traversableClassKey
applicativeClassKey, foldableClassKey,
traversableClassKey, alternativeClassKey
]
\end{code}
......
......@@ -20,7 +20,7 @@ module Inst (
newOverloadedLit, mkOverLit,
tcGetInstEnvs, getOverlapFlag,
tcGetInsts, tcGetInstEnvs, getOverlapFlag,
tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
tcSyntaxName,
......@@ -400,6 +400,10 @@ tcGetInstEnvs :: TcM (InstEnv, InstEnv)
tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
return (eps_inst_env eps, tcg_inst_env env) }
tcGetInsts :: TcM [ClsInst]
-- Gets the local class instances.
tcGetInsts = fmap tcg_insts getGblEnv
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
-- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
......
......@@ -75,7 +75,7 @@ import DataCon
import Type
import Class
import CoAxiom
import Inst ( tcGetInstEnvs )
import Inst ( tcGetInstEnvs, tcGetInsts )
import Data.List ( sortBy )
import Data.IORef ( readIORef )
import Data.Ord
......@@ -911,7 +911,147 @@ rnTopSrcDecls extra_deps group
return (tcg_env', rn_decls)
}
------------------------------------------------
-- ########## BEGIN AMP WARNINGS ###############################################
--
-- The functions defined here issue warnings according to the 2013
-- Applicative-Monad proposal. (#8004)
-- | Main entry point for generating AMP warnings
tcAmpWarn :: TcM ()
tcAmpWarn =
do { warnFlag <- woptM Opt_WarnAMP
; when warnFlag $ do {
-- Monad without Applicative
; tcAmpMissingParentClassWarn monadClassName
applicativeClassName
-- MonadPlus without Alternative
; tcAmpMissingParentClassWarn monadPlusClassName
alternativeClassName
-- Custom local definitions of join/pure/<*>
; mapM_ tcAmpFunctionWarn [joinMName, apAName, pureAName]
}}
-- | Warn on local definitions of names that would clash with Prelude versions,
-- i.e. join/pure/<*>
tcAmpFunctionWarn :: Name -- ^ Name to check, e.g. joinMName for join
-> TcM ()
tcAmpFunctionWarn name = do
{ rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv
-- Finds *other* elements having the same literal name. A name clashes
-- iff:
-- 1. It is locally defined in the current module
-- 2. It has the same literal name as the reference function
-- 3. It is not identical to the reference function
; let clashes :: GlobalRdrElt -> Bool
clashes x = and [ gre_prov x == LocalDef
, nameOccName (gre_name x) == nameOccName name
, gre_name x /= name
]
-- List of all offending definitions
clashingElts :: [GlobalRdrElt]
clashingElts = filter clashes rdrElts
; traceTc "tcAmpFunctionWarn/amp_prelude_functions"
(hang (ppr name) 4 (sep [ppr clashingElts]))
; let warn_msg x = addWarnAt (nameSrcSpan $ gre_name x) . hsep $
[ ptext (sLit "Local definition of")
, quotes . ppr . nameOccName $ gre_name x
, ptext (sLit "clashes with a future Prelude name")
, ptext (sLit "- this will become an error in GHC 7.10,")
, ptext (sLit "under the Applicative-Monad Proposal.")
]
; mapM_ warn_msg clashingElts
}
-- | Issue a warning for instance definitions lacking a should-be parent class.
-- Used for Monad without Applicative and MonadPlus without Alternative.
tcAmpMissingParentClassWarn :: Name -- ^ Class instance is defined for
-> Name -- ^ Class it should also be instance of
-> TcM ()
-- Notation: is* is for classes the type is an instance of, should* for those
-- that it should also be an instance of based on the corresponding
-- is*.
-- Example: in case of Applicative/Monad: is = Monad,
-- should = Applicative
tcAmpMissingParentClassWarn isName shouldName
= do { isClass' <- tcLookupClassMaybe isName -- Note [tryTc oddity]
; shouldClass' <- tcLookupClassMaybe shouldName -- Note [tryTc oddity]
; case (isClass', shouldClass') of
(Just isClass, Just shouldClass) -> do
{ localInstances <- tcGetInsts
; let isInstance m = is_cls m == isClass
isInsts = filter isInstance localInstances
; traceTc "tcAmpMissingParentClassWarn/isInsts" (ppr isInsts)
; forM_ isInsts $ checkShouldInst isClass shouldClass
}
_ -> return ()
}
where
-- Checks whether the desired superclass exists in a given environment.
checkShouldInst :: Class -- ^ Class of existing instance
-> Class -- ^ Class there should be an instance of
-> ClsInst -- ^ Existing instance
-> TcM ()
checkShouldInst isClass shouldClass isInst
= do { instEnv <- tcGetInstEnvs
; let (instanceMatches, shouldInsts, _)
= lookupInstEnv instEnv shouldClass (is_tys isInst)
; traceTc "tcAmpMissingParentClassWarn/checkShouldInst"
(hang (ppr isInst) 4
(sep [ppr instanceMatches, ppr shouldInsts]))
-- "<location>: Warning: <type> is an instance of <is> but not <should>"
-- e.g. "Foo is an instance of Monad but not Applicative"
; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
warnMsg (Just name:_) =
addWarnAt instLoc . hsep $
[ quotes (ppr $ nameOccName name)
, ptext (sLit "is an instance of")
, ppr . nameOccName $ className isClass
, ptext (sLit "but not")
, ppr . nameOccName $ className shouldClass
, ptext (sLit "- this will become an error in GHC 7.10,")
, ptext (sLit "under the Applicative-Monad Proposal.")
]
warnMsg _ = return ()
; when (null shouldInsts && null instanceMatches) $
warnMsg (is_tcs isInst)
}
{-
Note [tryTc oddity]
~~~~~~~~~~~~~~~~~~~
tcLookupClass in tcLookupClassMaybe should fail all on its own if the
given name doesn't exist, and the names we're looking for in the AMP
check should always exist. However, under some mysterious
circumstances, base apparently fails to compile without catching the
errors via tryTc. So tcLookupClassMaybe wraps all this behavior
together.
-}
-- | Looks up a class, returning Nothing on failure. Similar to
-- TcEnv.tcLookupClass, but does not issue any error messages.
tcLookupClassMaybe :: Name -> TcM (Maybe Class)
tcLookupClassMaybe = fmap toMaybe . tryTc . tcLookupClass
where toMaybe (_, Just cls) = Just cls
toMaybe _ = Nothing
-- ########## END AMP WARNINGS #################################################
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_details
(HsGroup { hs_tyclds = tycl_decls,
......@@ -934,6 +1074,11 @@ tcTopSrcDecls boot_details
<- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
setGblEnv tcg_env $ do {
-- Generate Applicative/Monad proposal (AMP) warnings
traceTc "Tc3b" empty ;
tcAmpWarn ;
-- Foreign import declarations next.
traceTc "Tc4" empty ;
(fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
......
......@@ -185,6 +185,31 @@
<replaceable>N</replaceable> modules in parallel.
</para>
</listitem>
<listitem>
<para>
GHC now generates warnings when definitions conflict with the
Applicative-Monad Proposal (AMP).
TODO FIXME: reference.
</para>
<para>
A warning is emitted if a type is an instance of
<literal>Monad</literal> but not of
<literal>Applicative</literal>,
<literal>MonadPlus</literal> but not
<literal>Alternative</literal>, and when a local
function named <literal>join</literal>,
<literal>&lt;*&gt;</literal> or <literal>pure</literal> is
defined.
</para>
<para>
The warnings are enabled by default, and can be controlled
using the new flag <literal>-f[no-]warn-amp</literal>.
</para>
</listitem>
</itemizedlist>
</sect2>
......
......@@ -1502,6 +1502,13 @@
<entry><option>-fno-warn-warnings-deprecations</option></entry>
</row>
<row>
<entry><option>-fwarn-amp</option></entry>
<entry>warn on definitions conflicting with the Applicative-Monad Proposal (AMP)</entry>
<entry>dynamic</entry>
<entry><option>-fno-warn-amp</option></entry>
</row>
</tbody>
</tgroup>
</informaltable>
......
......@@ -966,6 +966,7 @@ test.hs:(5,4)-(6,7):
program. These are:
<option>-fwarn-overlapping-patterns</option>,
<option>-fwarn-warnings-deprecations</option>,
<option>-fwarn-amp</option>,
<option>-fwarn-deprecated-flags</option>,
<option>-fwarn-unrecognised-pragmas</option>,
<option>-fwarn-pointless-pragmas</option>,
......@@ -1129,6 +1130,24 @@ test.hs:(5,4)-(6,7):
</listitem>
</varlistentry>
<varlistentry>
<term><option>-fwarn-amp</option>:</term>
<listitem>
<indexterm><primary><option>-fwarn-amp</option></primary>
</indexterm>
<indexterm><primary>amp</primary></indexterm>
<indexterm><primary>applicative-monad proposal</primary></indexterm>
<para>Causes a warning to be emitted when a definition
is in conflict with the AMP (Applicative-Monad proosal),
namely:
1. Instance of Monad without Applicative;
2. Instance of MonadPlus without Alternative;
3. Custom definitions of join/pure/&lt;*&gt;</para>
<para>This option is on by default.</para>
</listitem>
</varlistentry>
<varlistentry>
<term><option>-fwarn-deprecated-flags</option>:</term>
<listitem>
......
......@@ -32,6 +32,8 @@ SRC_HC_OPTS += $(WERROR) -Wall
GhcStage1HcOpts += -fwarn-tabs
GhcStage2HcOpts += -fwarn-tabs
GhcStage2HcOpts += -fno-warn-amp # Temporary sledgehammer until we sync upstream.
utils/hpc_dist-install_EXTRA_HC_OPTS += -fwarn-tabs
#####################
......@@ -44,6 +46,7 @@ GhcStage2HcOpts += -O -dcore-lint
# running of the tests, and faster building of the utils to be installed
GhcLibHcOpts += -O -dcore-lint
GhcLibHcOpts += -fno-warn-amp # Temporary sledgehammer until we sync upstream.
# We define DefaultFastGhcLibWays in this style so that the value is
# correct even if the user alters DYNAMIC_GHC_PROGRAMS.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment