ghc-7.10 does not like Monad instances that are not Functor and Applicative instances...
authorNing Wang <email@ningwang.org>
Wed, 6 May 2015 02:10:33 +0000 (19:10 -0700)
committerNing Wang <email@ningwang.org>
Wed, 6 May 2015 02:10:33 +0000 (19:10 -0700)
testing/Ast2ir.hs
testing/EvalMonad.hs
testing/OptSupport.hs

index ff227e8..56f0778 100644 (file)
@@ -1,11 +1,19 @@
 {-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-}
+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-}
 module Ast2ir (astToIR, IdLabelMap) where
 
 import           Compiler.Hoopl
 import           Control.Monad
 import qualified Data.Map       as M
 
+#if CABAL
+#if !MIN_VERSION_base(4,8,0)
+import qualified Control.Applicative as AP (Applicative(..))
+#endif
+#else
+import qualified Control.Applicative as AP (Applicative(..)) 
+#endif
+
 import qualified Ast as A
 import qualified IR  as I
 
@@ -67,11 +75,21 @@ toLast (A.Return es)      = return $ I.Return es
 
 type IdLabelMap = M.Map String Label
 data LabelMapM a = LabelMapM (IdLabelMap -> I.M (IdLabelMap, a))
+
 instance Monad LabelMapM where
   return x = LabelMapM (\m -> return (m, x))
   LabelMapM f1 >>= k = LabelMapM (\m -> do (m', x) <- f1 m
                                            let (LabelMapM f2) = k x
                                            f2 m')
+                       
+instance Functor LabelMapM where                       
+  fmap = liftM
+  
+instance AP.Applicative LabelMapM where  
+  pure = return
+  (<*>) = ap
+
+  
 labelFor l = LabelMapM f
   where f m = case M.lookup l m of
                 Just l' -> return (m, l')
index 024d585..628a1f9 100644 (file)
@@ -1,5 +1,5 @@
 {-# OPTIONS_GHC -Wall #-}
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
 
 module EvalMonad (ErrorM, VarEnv, B, State,
                   EvalM, runProg, inNewFrame, get_proc, get_block,
@@ -10,6 +10,14 @@ import Control.Monad.Error
 import qualified Data.Map as M
 import Prelude hiding (succ)
 
+#if CABAL
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative (Applicative(..))
+#endif
+#else
+import Control.Applicative (Applicative(..))
+#endif
+
 import Compiler.Hoopl
 import IR
 
@@ -26,6 +34,15 @@ instance Monad (EvalM v) where
   EvalM f >>= k = EvalM $ \s -> do (s', x) <- f s
                                    let EvalM f' = k x
                                    f' s'
+
+instance Functor (EvalM v) where
+  fmap = liftM
+
+instance Applicative (EvalM v) where
+  pure = return
+  (<*>) = ap
+
+
 instance MonadError String (EvalM v) where
   throwError e = EvalM (\s -> throwError (s, e))
   catchError (EvalM f) handler =
index 11eaa63..dacbcc4 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, RankNTypes #-}
+{-# LANGUAGE CPP, GADTs, RankNTypes #-}
 {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
 module OptSupport (mapVE, mapEE, mapEN, mapVN, fold_EE, fold_EN, insnToG) where
 
@@ -6,6 +6,14 @@ import Control.Monad
 import Data.Maybe
 import Prelude hiding (succ)
 
+#if CABAL
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative (Applicative(..))
+#endif
+#else
+import Control.Applicative (Applicative(..))
+#endif
+
 import Compiler.Hoopl
 import IR
 
@@ -34,6 +42,14 @@ instance Monad Mapped where
     where asNew (Old a)   = New a
           asNew m@(New _) = m
 
+instance Functor Mapped where
+  fmap = liftM
+  
+instance Applicative Mapped where
+  pure = return
+  (<*>) = ap
+
+
 makeTotal :: (a -> Maybe a) -> (a -> Mapped a)
 makeTotal f a = case f a of Just a' -> New a'
                             Nothing -> Old a