[commit: packages/hoopl] master: Add Functor/Applicative instances to silence AMP warnings (8f0d3cf)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/hoopl

On branch  : master
Link       : http://git.haskell.org/packages/hoopl.git/commitdiff/8f0d3cff4455fcd8f445ffe08bca2ddfa484ef54

>---------------------------------------------------------------

commit 8f0d3cff4455fcd8f445ffe08bca2ddfa484ef54
Author: Herbert Valerio Riedel <hvr at gnu.org>
Date:   Fri Oct 25 10:31:11 2013 +0200

    Add Functor/Applicative instances to silence AMP warnings
    
    This commit follows the suggestions from
    
     http://www.haskell.org/haskellwiki/Functor-Applicative-Monad_Proposal#Future-proofing_current_code
    
    Signed-off-by: Herbert Valerio Riedel <hvr at gnu.org>


>---------------------------------------------------------------

8f0d3cff4455fcd8f445ffe08bca2ddfa484ef54
 src/Compiler/Hoopl/Fuel.hs    |   18 ++++++++++++++++++
 src/Compiler/Hoopl/Graph.hs   |   18 ++++++++++++++----
 src/Compiler/Hoopl/MkGraph.hs |    4 +++-
 src/Compiler/Hoopl/Unique.hs  |   14 +++++++++++++-
 4 files changed, 48 insertions(+), 6 deletions(-)

diff --git a/src/Compiler/Hoopl/Fuel.hs b/src/Compiler/Hoopl/Fuel.hs
index 171502a..3811f32 100644
--- a/src/Compiler/Hoopl/Fuel.hs
+++ b/src/Compiler/Hoopl/Fuel.hs
@@ -21,6 +21,9 @@ where
 import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Unique
 
+import Control.Applicative (Applicative(..))
+import Control.Monad (ap,liftM)
+
 class Monad m => FuelMonad m where
   getFuel :: m Fuel
   setFuel :: Fuel -> m ()
@@ -50,6 +53,13 @@ withFuel (Just a) = do f <- getFuel
 
 newtype CheckingFuelMonad m a = FM { unFM :: Fuel -> m (a, Fuel) }
 
+instance Monad m => Functor (CheckingFuelMonad m) where
+  fmap  = liftM
+
+instance Monad m => Applicative (CheckingFuelMonad m) where
+  pure  = return
+  (<*>) = ap
+
 instance Monad m => Monad (CheckingFuelMonad m) where
   return a = FM (\f -> return (a, f))
   fm >>= k = FM (\f -> do { (a, f') <- unFM fm f; unFM (k a) f' })
@@ -74,6 +84,14 @@ instance FuelMonadT CheckingFuelMonad where
 ----------------------------------------------------------------
 
 newtype InfiniteFuelMonad m a = IFM { unIFM :: m a }
+
+instance Monad m => Functor (InfiniteFuelMonad m) where
+  fmap  = liftM
+
+instance Monad m => Applicative (InfiniteFuelMonad m) where
+  pure  = return
+  (<*>) = ap
+
 instance Monad m => Monad (InfiniteFuelMonad m) where
   return a = IFM $ return a
   m >>= k  = IFM $ do { a <- unIFM m; unIFM (k a) }
diff --git a/src/Compiler/Hoopl/Graph.hs b/src/Compiler/Hoopl/Graph.hs
index 4cde66a..b553648 100644
--- a/src/Compiler/Hoopl/Graph.hs
+++ b/src/Compiler/Hoopl/Graph.hs
@@ -46,8 +46,8 @@ import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Block
 import Compiler.Hoopl.Label
 
-import Control.Monad
-
+import Control.Applicative (Applicative(..))
+import Control.Monad (ap,liftM,liftM2)
 
 -- -----------------------------------------------------------------------------
 -- Body
@@ -348,12 +348,22 @@ postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty
 ----------------------------------------------------------------
 
 data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }
-marked :: Label -> VM Bool
-mark   :: Label -> VM ()
+
+instance Functor VM where
+  fmap  = liftM
+
+instance Applicative VM where
+  pure  = return
+  (<*>) = ap
+
 instance Monad VM where
   return a = VM $ \visited -> (a, visited)
   m >>= k  = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'
+
+marked :: Label -> VM Bool
 marked l = VM $ \v -> (setMember l v, v)
+
+mark   :: Label -> VM ()
 mark   l = VM $ \v -> ((), setInsert l v)
 
 preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)
diff --git a/src/Compiler/Hoopl/MkGraph.hs b/src/Compiler/Hoopl/MkGraph.hs
index 667c47b..4da5b19 100644
--- a/src/Compiler/Hoopl/MkGraph.hs
+++ b/src/Compiler/Hoopl/MkGraph.hs
@@ -18,7 +18,9 @@ import Compiler.Hoopl.Label (Label, uniqueToLbl)
 import Compiler.Hoopl.Block
 import Compiler.Hoopl.Graph as U
 import Compiler.Hoopl.Unique
-import Control.Monad (liftM2)
+
+import Control.Monad (Monad(..),liftM2)
+import Prelude (($),(.),foldr,map) -- for the purpose of 'hiding ((<*>))'
 
 {-|
 As noted in the paper, we can define a single, polymorphic type of 
diff --git a/src/Compiler/Hoopl/Unique.hs b/src/Compiler/Hoopl/Unique.hs
index e4ca86c..8ea85ce 100644
--- a/src/Compiler/Hoopl/Unique.hs
+++ b/src/Compiler/Hoopl/Unique.hs
@@ -21,7 +21,8 @@ import Compiler.Hoopl.Collections
 import qualified Data.IntMap as M
 import qualified Data.IntSet as S
 
-import Control.Monad (liftM)
+import Control.Applicative (Applicative(..))
+import Control.Monad (ap,liftM)
 
 -----------------------------------------------------------------------------
 --		Unique
@@ -111,6 +112,10 @@ newtype SimpleUniqueMonad a = SUM { unSUM :: [Unique] -> (a, [Unique]) }
 instance Functor SimpleUniqueMonad where
   fmap = liftM
 
+instance Applicative SimpleUniqueMonad where
+  pure  = return
+  (<*>) = ap
+
 instance Monad SimpleUniqueMonad where
   return a = SUM $ \us -> (a, us)
   m >>= k  = SUM $ \us -> let (a, us') = unSUM m us in
@@ -133,6 +138,13 @@ runSimpleUniqueMonad m = fst (unSUM m allUniques)
 
 newtype UniqueMonadT m a = UMT { unUMT :: [Unique] -> m (a, [Unique]) }
 
+instance Monad m => Functor (UniqueMonadT m) where
+  fmap  = liftM
+
+instance Monad m => Applicative (UniqueMonadT m) where
+  pure  = return
+  (<*>) = ap
+
 instance Monad m => Monad (UniqueMonadT m) where
   return a = UMT $ \us -> return (a, us)
   m >>= k  = UMT $ \us -> do { (a, us') <- unUMT m us; unUMT (k a) us' }