Commit 814d4ef3 authored by Ning Wang's avatar Ning Wang

ghc-7.10 does not like Monad instances that are not Functor and Applicative...

ghc-7.10 does not like Monad instances that are not Functor and Applicative instances. Made them instances of Functor and Applicative so the build can pass in Travis CI.
parent 2081adaa
{-# 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')
......
{-# 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 =
......
{-# 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment