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: Dan Rosén <danr@chalmers.se>
Authored-by: David Luposchainsky <dluposchainsky@gmail.com>
Signed-off-by: Austin Seipp <austin@well-typed.com>

8 files changed, 237 insertions, 6 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index bcf4ccf370..965683c177 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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,
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 3e5384bc5f..b428f6e375 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -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}
 
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index f6e7b019a0..1047f162fa 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -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
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 1f0da6b3cf..d918cba0c9 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -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 ;
diff --git a/docs/users_guide/7.8.1-notes.xml b/docs/users_guide/7.8.1-notes.xml
index 21f5419a1b..d02c32d337 100644
--- a/docs/users_guide/7.8.1-notes.xml
+++ b/docs/users_guide/7.8.1-notes.xml
@@ -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>
 
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 43f843d6ee..00b632d698 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -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>
diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index f03335862b..c2b4a17eb8 100644
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -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>,
@@ -1130,6 +1131,24 @@ test.hs:(5,4)-(6,7):
       </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>
           <indexterm><primary><option>-fwarn-deprecated-flags</option></primary>
diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk
index ba645a4190..8797bf9a73 100644
--- a/mk/validate-settings.mk
+++ b/mk/validate-settings.mk
@@ -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.