Commit 0b1bea43 authored by thoughtpolice's avatar thoughtpolice
Browse files

Fix most AMP warnings.


Authored-by: quchen's avatarDavid Luposchainsky <dluposchainsky@gmail.com>
Signed-off-by: thoughtpolice's avatarAustin Seipp <aseipp@pobox.com>
parent 8859e1e3
...@@ -50,6 +50,9 @@ module DriverPipeline (compileFile) where ...@@ -50,6 +50,9 @@ module DriverPipeline (compileFile) where
import Control.Exception import Control.Exception
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
data Phase data Phase
= Unlit () = Unlit ()
| Ccpp | Ccpp
...@@ -75,6 +78,13 @@ data PipeState = PipeState { ...@@ -75,6 +78,13 @@ data PipeState = PipeState {
newtype CompPipeline a = P { unP :: PipeState -> IO (PipeState, a) } 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 instance Monad CompPipeline where
return a = P $ \state -> return (state, a) return a = P $ \state -> return (state, a)
P m >>= k = P $ \state -> do (state',a) <- m state P m >>= k = P $ \state -> do (state',a) <- m state
......
...@@ -2,6 +2,9 @@ ...@@ -2,6 +2,9 @@
module Cpr001_imp where module Cpr001_imp where
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
data MS = MS { instr :: String data MS = MS { instr :: String
, pc :: Int , pc :: Int
, mem :: String , mem :: String
...@@ -18,6 +21,13 @@ newtype StateTrans s a = ST ( s -> (s, Maybe a)) ...@@ -18,6 +21,13 @@ newtype StateTrans s a = ST ( s -> (s, Maybe a))
-- as it is and Nothing is returned as value -- as it is and Nothing is returned as value
-- else execution continues -- else execution continues
instance Functor (StateTrans s) where
fmap = liftM
instance Applicative (StateTrans s) where
pure = return
(<*>) = ap
instance Monad (StateTrans s) where instance Monad (StateTrans s) where
(ST p) >>= k (ST p) >>= k
= ST (\s0 -> let = ST (\s0 -> let
......
...@@ -5,6 +5,9 @@ ...@@ -5,6 +5,9 @@
-- one-argument newtype defined in the same module -- one-argument newtype defined in the same module
module ShouldSucceed where module ShouldSucceed where
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
-- library stuff -- library stuff
class Monad m => MonadState s m | m -> s where class Monad m => MonadState s m | m -> s where
...@@ -15,6 +18,13 @@ newtype State s a = State { ...@@ -15,6 +18,13 @@ newtype State s a = State {
runState :: (s -> (a, s)) runState :: (s -> (a, s))
} }
instance Functor (State s) where
fmap = liftM
instance Applicative (State s) where
pure = return
(<*>) = ap
instance Monad (State s) where instance Monad (State s) where
return a = State $ \s -> (a, s) return a = State $ \s -> (a, s)
m >>= k = State $ \s -> let m >>= k = State $ \s -> let
...@@ -28,7 +38,7 @@ instance MonadState s (State s) where ...@@ -28,7 +38,7 @@ instance MonadState s (State s) where
-- test code -- test code
newtype Foo a = MkFoo (State Int a) newtype Foo a = MkFoo (State Int a)
deriving (Monad, MonadState Int) deriving (Functor, Applicative, Monad, MonadState Int)
f :: Foo Int f :: Foo Int
f = get f = get
...@@ -6,8 +6,10 @@ ...@@ -6,8 +6,10 @@
module ShouldCompile where module ShouldCompile where
import Control.Applicative (Applicative)
import Foreign.Ptr 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 () type RenderCallback = Int -> Int -> RenderM ()
......
...@@ -14,6 +14,9 @@ ...@@ -14,6 +14,9 @@
module Sample where module Sample where
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
data Safe data Safe
data MayFail data MayFail
...@@ -23,6 +26,13 @@ data Result s a where ...@@ -23,6 +26,13 @@ data Result s a where
newtype M s a = M { unM :: IO (Result s a) } 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 instance Monad (M s) where
return x = M (return (Ok x)) return x = M (return (Ok x))
......
...@@ -2,6 +2,9 @@ ...@@ -2,6 +2,9 @@
module Main where module Main where
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
-- abstract syntax ------------------------------------------------------------- -- abstract syntax -------------------------------------------------------------
data Ty t where data Ty t where
Bool :: Ty Bool Bool :: Ty Bool
...@@ -87,6 +90,13 @@ data Tree a = Val a | Choice (Tree a) (Tree a) ...@@ -87,6 +90,13 @@ data Tree a = Val a | Choice (Tree a) (Tree a)
-- Val :: a -> Tree a Z -- Val :: a -> Tree a Z
-- Choice :: Tree a n -> Tree a n -> Tree a (S n) -- 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 instance Monad Tree where
return x = Val x return x = Val x
(Val a) >>= f = f a (Val a) >>= f = f a
......
...@@ -6,6 +6,9 @@ import System.IO ...@@ -6,6 +6,9 @@ import System.IO
import System.IO.Unsafe import System.IO.Unsafe
import Debug.Trace import Debug.Trace
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
-- parser produced by Happy Version 1.16 -- parser produced by Happy Version 1.16
data HappyAbsSyn data HappyAbsSyn
...@@ -166,6 +169,13 @@ newtype HappyIdentity a = HappyIdentity a ...@@ -166,6 +169,13 @@ newtype HappyIdentity a = HappyIdentity a
happyIdentity = HappyIdentity happyIdentity = HappyIdentity
happyRunIdentity (HappyIdentity a) = a happyRunIdentity (HappyIdentity a) = a
instance Functor HappyIdentity where
fmap = liftM
instance Applicative HappyIdentity where
pure = return
(<*>) = ap
instance Monad HappyIdentity where instance Monad HappyIdentity where
return = HappyIdentity return = HappyIdentity
(HappyIdentity p) >>= q = q p (HappyIdentity p) >>= q = q p
......
Breakpoint 0 activated at ../HappyTest.hs:(216,1)-(227,35) Breakpoint 0 activated at ../HappyTest.hs:(226,1)-(237,35)
Stopped at ../HappyTest.hs:(216,1)-(227,35) Stopped at ../HappyTest.hs:(226,1)-(237,35)
_result :: [Token] = _ _result :: [Token] = _
*** Ignoring breakpoint *** Ignoring breakpoint
*** Ignoring breakpoint *** Ignoring breakpoint
......
...@@ -2,6 +2,8 @@ ...@@ -2,6 +2,8 @@
module ShouldCompile where module ShouldCompile where
import Control.Applicative (Applicative)
data family S a data family S a
newtype instance S Int = S Int newtype instance S Int = S Int
...@@ -10,5 +12,5 @@ newtype instance S Int = S Int ...@@ -10,5 +12,5 @@ newtype instance S Int = S Int
data family S2 a b data family S2 a b
newtype instance S2 Int b = S2 (IO b) newtype instance S2 Int b = S2 (IO b)
deriving Monad deriving (Functor, Applicative, Monad)
...@@ -10,8 +10,18 @@ module Main (main) where ...@@ -10,8 +10,18 @@ module Main (main) where
import Control.Monad.Fix import Control.Monad.Fix
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
data X a = X a deriving Show data X a = X a deriving Show
instance Functor X where
fmap = liftM
instance Applicative X where
pure = return
(<*>) = ap
instance Monad X where instance Monad X where
return = X return = X
(X a) >>= f = f a (X a) >>= f = f a
......
...@@ -7,8 +7,18 @@ module Foo where ...@@ -7,8 +7,18 @@ module Foo where
import qualified Prelude import qualified Prelude
import Prelude hiding (Monad(..)) import Prelude hiding (Monad(..))
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
newtype Identity a = Identity { runIdentity :: a } 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 instance Prelude.Monad Identity where
return a = Identity a return a = Identity a
m >>= k = k (runIdentity m) m >>= k = k (runIdentity m)
......
...@@ -2,5 +2,7 @@ ...@@ -2,5 +2,7 @@
{-# OPTIONS_GHC -Wall -Werror #-} {-# OPTIONS_GHC -Wall -Werror #-}
module Bug(P) where 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)
{-# LANGUAGE CPP #-}
module T7145b ( A.Applicative(pure) ) where module T7145b ( A.Applicative(pure) ) where
import qualified Control.Applicative as A import qualified Control.Applicative as A
......
T7145b.hs:6:1: Warning: Defined but not used: ‛pure’ T7145b.hs:8:1: Warning: Defined but not used: ‛pure’
...@@ -4,6 +4,7 @@ ...@@ -4,6 +4,7 @@
module Simpl009Help where module Simpl009Help where
import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))
import Control.Monad import Control.Monad
newtype Parser s a newtype Parser s a
...@@ -14,6 +15,13 @@ data P s res ...@@ -14,6 +15,13 @@ data P s res
| Fail [String] [String] | Fail [String] [String]
| Result res (P s res) | 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 instance Monad (Parser s) where
return a = Parser (\fut -> fut a) return a = Parser (\fut -> fut a)
...@@ -23,6 +31,10 @@ instance Monad (Parser s) where ...@@ -23,6 +31,10 @@ instance Monad (Parser s) where
fail s = fail s =
Parser (\fut exp -> Fail exp [s]) Parser (\fut exp -> Fail exp [s])
instance Alternative (Parser s) where
empty = mzero
(<|>) = mplus
instance MonadPlus (Parser s) where instance MonadPlus (Parser s) where
mplus = error "urk" mplus = error "urk"
mzero = Parser (\fut exp -> Fail exp []) mzero = Parser (\fut exp -> Fail exp [])
......
...@@ -11,8 +11,18 @@ module EvalTest where ...@@ -11,8 +11,18 @@ module EvalTest where
import GHC.Conc import GHC.Conc
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
data Eval a = Done a data Eval a = Done a
instance Functor Eval where
fmap = liftM
instance Applicative Eval where
pure = return
(<*>) = ap
instance Monad Eval where instance Monad Eval where
return x = Done x return x = Done x
Done x >>= k = k x -- Note: pattern 'Done x' makes '>>=' strict Done x >>= k = k x -- Note: pattern 'Done x' makes '>>=' strict
......
...@@ -6,6 +6,7 @@ ...@@ -6,6 +6,7 @@
module T3831(setAttributes) where module T3831(setAttributes) where
import Data.Monoid import Data.Monoid
import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))
import Control.Monad import Control.Monad
class (Monoid s, OutputCap s) => TermStr s class (Monoid s, OutputCap s) => TermStr s
...@@ -17,13 +18,13 @@ class OutputCap f where ...@@ -17,13 +18,13 @@ class OutputCap f where
instance OutputCap [Char] where instance OutputCap [Char] where
instance (Enum p, OutputCap f) => OutputCap (p -> f) where instance (Enum p, OutputCap f) => OutputCap (p -> f) where
instance MonadPlus Capability where
mzero = Capability (const $ return Nothing) instance Functor Capability where
Capability f `mplus` Capability g = Capability $ \t -> do fmap = liftM
mx <- f t
case mx of instance Applicative Capability where
Nothing -> g t pure = return
_ -> return mx (<*>) = ap
instance Monad Capability where instance Monad Capability where
return = Capability . const . return . Just return = Capability . const . return . Just
...@@ -33,6 +34,18 @@ instance Monad Capability where ...@@ -33,6 +34,18 @@ instance Monad Capability where
Nothing -> return Nothing Nothing -> return Nothing
Just x -> let Capability g' = g x in g' t 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)) newtype Capability a = Capability (() -> IO (Maybe a))
tiGetOutput1 :: forall f . OutputCap f => String -> Capability f tiGetOutput1 :: forall f . OutputCap f => String -> Capability f
......
...@@ -4,6 +4,8 @@ ...@@ -4,6 +4,8 @@
module T4203 where module T4203 where
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
newtype NonNegative a = NonNegative a newtype NonNegative a = NonNegative a
deriving (Eq, Num, Show) deriving (Eq, Num, Show)
...@@ -26,6 +28,13 @@ instance Arbitrary EmptyStackSet where ...@@ -26,6 +28,13 @@ instance Arbitrary EmptyStackSet where
newtype Gen a = Gen a newtype Gen a = Gen a
instance Functor Gen where
fmap = liftM
instance Applicative Gen where
pure = return
(<*>) = ap
instance Monad Gen where instance Monad Gen where
return a = Gen a return a = Gen a
Gen m >>= k = Gen (let Gen m' = k m in m') Gen m >>= k = Gen (let Gen m' = k m in m')
......
...@@ -5,9 +5,19 @@ ...@@ -5,9 +5,19 @@
module T3955 where module T3955 where
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
class (Monad m) => MonadReader r m class (Monad m) => MonadReader r m
newtype Reader r a = Reader { runReader :: r -> a } 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 instance Monad (Reader r) where
(>>=) = error "urk" (>>=) = error "urk"
return = error "urk" return = error "urk"
...@@ -15,7 +25,7 @@ instance Monad (Reader r) where ...@@ -15,7 +25,7 @@ instance Monad (Reader r) where
instance MonadReader r (Reader r) instance MonadReader r (Reader r)
newtype T a x = T (Reader a x) 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 ) [1 of 1] Compiling Main ( bug.hs, interpreted )
......
...@@ -6,6 +6,8 @@ ...@@ -6,6 +6,8 @@
module Storage.Hashed.Monad () where module Storage.Hashed.Monad () where
import Control.Applicative (Applicative(..))
class Monad m => TreeRO m where class Monad m => TreeRO m where
withDirectory :: (MonadError e m) => Int -> m a -> m a withDirectory :: (MonadError e m) => Int -> m a -> m a
expandTo :: (MonadError e m) => Int -> m Int expandTo :: (MonadError e m) => Int -> m Int
...@@ -18,6 +20,13 @@ instance (Monad m, MonadError e m) => TreeRO (M m) where ...@@ -18,6 +20,13 @@ instance (Monad m, MonadError e m) => TreeRO (M m) where
data M (m :: * -> *) a 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 instance Monad m => Monad (M m) where
(>>=) = undefined (>>=) = undefined
return = undefined return = undefined
......
Markdown is supported