Add Functor/Applicative instances to silence AMP warnings
authorHerbert Valerio Riedel <hvr@gnu.org>
Fri, 25 Oct 2013 08:31:11 +0000 (10:31 +0200)
committerHerbert Valerio Riedel <hvr@gnu.org>
Fri, 25 Oct 2013 08:33:49 +0000 (10:33 +0200)
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@gnu.org>
src/Compiler/Hoopl/Fuel.hs
src/Compiler/Hoopl/Graph.hs
src/Compiler/Hoopl/MkGraph.hs
src/Compiler/Hoopl/Unique.hs

index 171502a..3811f32 100644 (file)
@@ -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) }
index 4cde66a..b553648 100644 (file)
@@ -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)
index 667c47b..4da5b19 100644 (file)
@@ -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 
index e4ca86c..8ea85ce 100644 (file)
@@ -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' }