Fix most AMP warnings.

Authored-by: David Luposchainsky <dluposchainsky@gmail.com>
Signed-off-by: Austin Seipp <aseipp@pobox.com>

testsuite/tests/codeGen/should_compile/jmp_tbl.hs

@@ -50,6 +50,9 @@ module DriverPipeline (compileFile) where
 
 import Control.Exception
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 data Phase
         = Unlit ()
         | Ccpp
@@ -75,6 +78,13 @@ data PipeState = PipeState {
 
 newtype CompPipeline a = P { unP :: PipeState -> IO (PipeState, a) }
 
+instance Functor CompPipeline where
+    fmap = liftM
+
+instance Applicative CompPipeline where
+    pure = return
+    (<*>) = ap
+
 instance Monad CompPipeline where
   return a = P $ \state -> return (state, a)
   P m >>= k = P $ \state -> do (state',a) <- m state

testsuite/tests/cpranal/should_compile/Cpr001_imp.hs

@@ -2,6 +2,9 @@
 
 module Cpr001_imp where
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 data MS		= MS { instr	:: String
 		     , pc	:: Int
 		     , mem	:: String
@@ -18,6 +21,13 @@ newtype StateTrans s a = ST ( s -> (s, Maybe a))
 -- as it is and Nothing is returned as value
 -- else execution continues
 
+instance Functor (StateTrans s) where
+    fmap = liftM
+
+instance Applicative (StateTrans s) where
+    pure = return
+    (<*>) = ap
+
 instance Monad (StateTrans s) where
     (ST p) >>= k
 	= ST (\s0 -> let

testsuite/tests/deriving/should_compile/drv020.hs

@@ -5,6 +5,9 @@
 -- one-argument newtype defined in the same module
 module ShouldSucceed where
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 -- library stuff
 
 class Monad m => MonadState s m | m -> s where
@@ -15,6 +18,13 @@ newtype State s a = State {
                            runState :: (s -> (a, s))
                           }
 
+instance Functor (State s) where
+    fmap = liftM
+
+instance Applicative (State s) where
+    pure = return
+    (<*>) = ap
+
 instance Monad (State s) where
 	return a = State $ \s -> (a, s)
 	m >>= k  = State $ \s -> let
@@ -28,7 +38,7 @@ instance MonadState s (State s) where
 -- test code
 
 newtype Foo a = MkFoo (State Int a)
- deriving (Monad, MonadState Int)
+ deriving (Functor, Applicative, Monad, MonadState Int)
 
 f :: Foo Int
 f = get

testsuite/tests/ffi/should_compile/ffi-deriv1.hs

-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 -- Tests newtype unwrapping for the IO monad itself
 -- Notice the RenderM monad, which is used in the
@@ -6,8 +6,10 @@
 
 module ShouldCompile where
 
+import Control.Applicative (Applicative)
+
 import Foreign.Ptr
-newtype RenderM a = RenderM (IO a) deriving (Functor, Monad)
+newtype RenderM a = RenderM (IO a) deriving (Functor, Applicative, Monad)
 
 type RenderCallback = Int -> Int -> RenderM ()
 

testsuite/tests/gadt/gadt16.hs

@@ -14,6 +14,9 @@
 
 module Sample where
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 data Safe
 data MayFail
 
@@ -23,6 +26,13 @@ data Result s a where
 
 newtype M s a = M { unM :: IO (Result s a) }
 
+instance Functor (M s) where
+    fmap = liftM
+
+instance Applicative (M s) where
+    pure = return
+    (<*>) = ap
+
 instance Monad (M s) where  
 
   return x = M (return (Ok x))

testsuite/tests/gadt/nbe.hs

@@ -2,6 +2,9 @@
 
 module Main where
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 -- abstract syntax -------------------------------------------------------------
 data Ty t where
   Bool :: Ty Bool
@@ -87,6 +90,13 @@ data Tree a = Val a | Choice (Tree a) (Tree a)
 -- 	Val :: a -> Tree a Z
 -- 	Choice :: Tree a n -> Tree a n -> Tree a (S n)
 
+instance Functor Tree where
+    fmap = liftM
+
+instance Applicative Tree where
+    pure = return
+    (<*>) = ap
+
 instance Monad Tree where
   return x = Val x
   (Val a) >>= f = f a

testsuite/tests/ghci.debugger/HappyTest.hs

@@ -6,6 +6,9 @@ import System.IO
 import System.IO.Unsafe
 import Debug.Trace
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 -- parser produced by Happy Version 1.16
 
 data HappyAbsSyn 
@@ -166,6 +169,13 @@ newtype HappyIdentity a = HappyIdentity a
 happyIdentity = HappyIdentity
 happyRunIdentity (HappyIdentity a) = a
 
+instance Functor HappyIdentity where
+    fmap = liftM
+
+instance Applicative HappyIdentity where
+    pure = return
+    (<*>) = ap
+
 instance Monad HappyIdentity where
     return = HappyIdentity
     (HappyIdentity p) >>= q = q p

testsuite/tests/ghci.debugger/scripts/print020.stdout

-Breakpoint 0 activated at ../HappyTest.hs:(216,1)-(227,35)
-Stopped at ../HappyTest.hs:(216,1)-(227,35)
+Breakpoint 0 activated at ../HappyTest.hs:(226,1)-(237,35)
+Stopped at ../HappyTest.hs:(226,1)-(237,35)
 _result :: [Token] = _
 *** Ignoring breakpoint
 *** Ignoring breakpoint

testsuite/tests/indexed-types/should_compile/DerivingNewType.hs

@@ -2,6 +2,8 @@
 
 module ShouldCompile where
 
+import Control.Applicative (Applicative)
+
 data family S a
 
 newtype instance S Int = S Int
@@ -10,5 +12,5 @@ newtype instance S Int = S Int
 data family S2 a b
 
 newtype instance S2 Int b = S2 (IO b)
-		          deriving Monad
+		          deriving (Functor, Applicative, Monad)
 

testsuite/tests/mdo/should_fail/mdofail004.hs

@@ -10,8 +10,18 @@ module Main (main) where
 
 import Control.Monad.Fix
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 data X a = X a deriving Show
 
+instance Functor X where
+    fmap = liftM
+
+instance Applicative X where
+    pure = return
+    (<*>) = ap
+
 instance Monad X where
   return      = X
   (X a) >>= f = f a

testsuite/tests/rebindable/rebindable9.hs

@@ -7,8 +7,18 @@ module Foo where
 import qualified Prelude
 import Prelude hiding (Monad(..))
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 newtype Identity a = Identity { runIdentity :: a }
 
+instance Prelude.Functor Identity where
+    fmap = liftM
+
+instance Applicative Identity where
+    pure = Prelude.return
+    (<*>) = ap
+
 instance Prelude.Monad Identity where
     return a = Identity a
     m >>= k  = k (runIdentity m)

testsuite/tests/rename/should_compile/T1954.hs

@@ -2,5 +2,7 @@
 {-# OPTIONS_GHC -Wall -Werror #-}
 module Bug(P) where
 
-newtype P a = P (IO a) deriving Monad
+import Control.Applicative (Applicative)
+
+newtype P a = P (IO a) deriving (Functor, Applicative, Monad)
 

testsuite/tests/rename/should_compile/T7145b.hs

+{-# LANGUAGE CPP #-}
+
 module T7145b ( A.Applicative(pure) ) where
 
 import qualified Control.Applicative as A

testsuite/tests/rename/should_compile/T7145b.stderr

 
-T7145b.hs:6:1: Warning: Defined but not used: ‛pure’
+T7145b.hs:8:1: Warning: Defined but not used: ‛pure’

testsuite/tests/simplCore/prog002/Simpl009Help.hs

@@ -4,6 +4,7 @@
 
 module Simpl009Help where
   
+import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))
 import Control.Monad
 
 newtype Parser s a
@@ -14,6 +15,13 @@ data P s res
   | Fail [String] [String]
   | Result res (P s res)
 
+instance Functor (Parser s) where
+    fmap = liftM
+
+instance Applicative (Parser s) where
+    pure = return
+    (<*>) = ap
+
 instance Monad (Parser s) where
   return a = Parser (\fut -> fut a)
   
@@ -23,6 +31,10 @@ instance Monad (Parser s) where
   fail s =
     Parser (\fut exp -> Fail exp [s])
 
+instance Alternative (Parser s) where
+    empty = mzero
+    (<|>) = mplus
+
 instance MonadPlus (Parser s) where
   mplus = error "urk"
   mzero = Parser (\fut exp -> Fail exp [])

testsuite/tests/simplCore/should_compile/EvalTest.hs

@@ -11,8 +11,18 @@ module EvalTest where
 
 import GHC.Conc
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 data Eval a = Done a
 
+instance Functor Eval where
+    fmap = liftM
+
+instance Applicative Eval where
+    pure = return
+    (<*>) = ap
+
 instance Monad Eval where
   return x = Done x
   Done x >>= k = k x   -- Note: pattern 'Done x' makes '>>=' strict

testsuite/tests/simplCore/should_compile/T3831.hs

@@ -6,6 +6,7 @@
 module T3831(setAttributes)  where
 
 import Data.Monoid
+import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))
 import Control.Monad
 
 class (Monoid s, OutputCap s) => TermStr s
@@ -17,13 +18,13 @@ class OutputCap f where
 instance OutputCap [Char] where
 instance (Enum p, OutputCap f) => OutputCap (p -> f) where
 
-instance MonadPlus Capability where
-    mzero = Capability (const $ return Nothing)
-    Capability f `mplus` Capability g = Capability $ \t -> do
-        mx <- f t
-        case mx of
-            Nothing -> g t
-            _ -> return mx
+
+instance Functor Capability where
+    fmap = liftM
+
+instance Applicative Capability where
+    pure = return
+    (<*>) = ap
 
 instance Monad Capability where
     return = Capability . const . return . Just
@@ -33,6 +34,18 @@ instance Monad Capability where
             Nothing -> return Nothing
             Just x -> let Capability g' = g x in g' t
 
+instance Alternative Capability where
+    empty = mzero
+    (<|>) = mplus
+
+instance MonadPlus Capability where
+    mzero = Capability (const $ return Nothing)
+    Capability f `mplus` Capability g = Capability $ \t -> do
+        mx <- f t
+        case mx of
+            Nothing -> g t
+            _ -> return mx
+
 newtype Capability a = Capability (() -> IO (Maybe a))
 
 tiGetOutput1 :: forall f . OutputCap f => String -> Capability f

testsuite/tests/simplCore/should_compile/T4203.hs

@@ -4,6 +4,8 @@
 
 module T4203 where
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
 
 newtype NonNegative a = NonNegative a
  deriving (Eq, Num, Show)
@@ -26,6 +28,13 @@ instance Arbitrary EmptyStackSet where
 
 newtype Gen a = Gen a
 
+instance Functor Gen where
+    fmap = liftM
+
+instance Applicative Gen where
+    pure = return
+    (<*>) = ap
+
 instance Monad Gen where
   return a    = Gen a
   Gen m >>= k = Gen (let Gen m' = k m in m')

testsuite/tests/typecheck/should_compile/T3955.hs

@@ -5,9 +5,19 @@
 
 module T3955 where
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 class (Monad m) => MonadReader r m 
 newtype Reader r a = Reader { runReader :: r -> a }
 
+instance Functor (Reader r) where
+    fmap = liftM
+
+instance Applicative (Reader r) where
+    pure = return
+    (<*>) = ap
+
 instance Monad (Reader r) where
   (>>=)  = error "urk"
   return = error "urk"
@@ -15,7 +25,7 @@ instance Monad (Reader r) where
 instance MonadReader r (Reader r)
 
 newtype T a x = T (Reader a x)
-    deriving (Monad, MonadReader a)
+    deriving (Functor, Applicative, Monad, MonadReader a)
 
 {-
 [1 of 1] Compiling Main             ( bug.hs, interpreted )

testsuite/tests/typecheck/should_compile/T4952.hs

@@ -6,6 +6,8 @@
 
 module Storage.Hashed.Monad () where
 
+import Control.Applicative (Applicative(..))
+
 class Monad m => TreeRO m where
     withDirectory :: (MonadError e m) => Int -> m a -> m a
     expandTo :: (MonadError e m) => Int -> m Int
@@ -18,6 +20,13 @@ instance (Monad m, MonadError e m) => TreeRO (M m) where
 
 data M (m :: * -> *) a
 
+instance Functor (M m) where
+    fmap = undefined
+
+instance Applicative (M m) where
+    pure = undefined
+    (<*>) = undefined
+
 instance Monad m => Monad (M m) where
     (>>=) = undefined
     return = undefined

testsuite/tests/typecheck/should_compile/Tc239_Help.hs

-module Tc239_Help ( WrapIO, WrapIO2 ) where
-
-newtype WrapIO e a = MkWrapIO { unwrap :: IO a }
-
-type WrapIO2 a = WrapIO String a
-
-instance Monad (WrapIO e) where
-  return x = MkWrapIO (return x)
-
-  m >>= f  = MkWrapIO (do x <- unwrap m
-                          unwrap (f x) )
-
+module Tc239_Help ( WrapIO, WrapIO2 ) where
+
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
+newtype WrapIO e a = MkWrapIO { unwrap :: IO a }
+
+type WrapIO2 a = WrapIO String a
+
+instance Functor (WrapIO e) where
+    fmap = liftM
+
+instance Applicative (WrapIO e) where
+    pure = return
+    (<*>) = ap
+
+instance Monad (WrapIO e) where
+  return x = MkWrapIO (return x)
+
+  m >>= f  = MkWrapIO (do x <- unwrap m
+                          unwrap (f x) )
+
   fail str = error str
\ No newline at end of file

testsuite/tests/typecheck/should_compile/tc093.hs

 module ShouldSucceed where
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, ap)
+
 data State c a = State (c -> (a,c))
 
 unState :: State c a -> (c -> (a,c))
@@ -13,6 +16,13 @@ bindState m k = State (\s0 -> let (a,s1) = (unState m) s0
                                   (b,s2) = (unState (k a)) s1 
                               in (b,s2))
 
+instance Eq c => Functor (State c) where
+    fmap = liftM
+
+instance Eq c => Applicative (State c) where
+    pure = return
+    (<*>) = ap
+
 instance Eq c => Monad (State c) where
     return = unitState 
     (>>=)  = bindState 

testsuite/tests/typecheck/should_compile/tc258.hs

@@ -12,4 +12,4 @@ class MyFunctor f where
 class MyFunctor ap => MyApplicative ap where
        type ApplicativeCtxt ap a :: Constraint
        type ApplicativeCtxt ap a = FunctorCtxt ap a
-       (<*>) :: (ApplicativeCtxt ap a, ApplicativeCtxt ap b) => ap (a -> b) -> ap a -> ap b
+       (<***>) :: (ApplicativeCtxt ap a, ApplicativeCtxt ap b) => ap (a -> b) -> ap a -> ap b