Commit 1219f8e8 authored by Krzysztof Gogolewski's avatar Krzysztof Gogolewski Committed by Marge Bot

Use DeriveFunctor throughout the codebase (#15654)

parent 217e6db4
Pipeline #6965 failed with stages
in 601 minutes and 56 seconds
...@@ -4,6 +4,7 @@ ...@@ -4,6 +4,7 @@
-} -}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
#if !defined(GHC_LOADED_INTO_GHCI) #if !defined(GHC_LOADED_INTO_GHCI)
...@@ -148,20 +149,18 @@ pattern UniqResult x y = (# x, y #) ...@@ -148,20 +149,18 @@ pattern UniqResult x y = (# x, y #)
#else #else
data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply
deriving (Functor)
#endif #endif
-- | A monad which just gives the ability to obtain 'Unique's -- | A monad which just gives the ability to obtain 'Unique's
newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }
deriving (Functor)
instance Monad UniqSM where instance Monad UniqSM where
(>>=) = thenUs (>>=) = thenUs
(>>) = (*>) (>>) = (*>)
instance Functor UniqSM where
fmap f (USM x) = USM (\us0 -> case x us0 of
UniqResult r us1 -> UniqResult (f r) us1)
instance Applicative UniqSM where instance Applicative UniqSM where
pure = returnUs pure = returnUs
(USM f) <*> (USM x) = USM $ \us0 -> case f us0 of (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of
......
...@@ -5,6 +5,7 @@ ...@@ -5,6 +5,7 @@
-- CmmLint: checking the correctness of Cmm statements and expressions -- CmmLint: checking the correctness of Cmm statements and expressions
-- --
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
module CmmLint ( module CmmLint (
cmmLint, cmmLintGraph cmmLint, cmmLintGraph
...@@ -24,7 +25,7 @@ import PprCmm () ...@@ -24,7 +25,7 @@ import PprCmm ()
import Outputable import Outputable
import DynFlags import DynFlags
import Control.Monad (liftM, ap) import Control.Monad (ap)
-- Things to check: -- Things to check:
-- - invariant on CmmBlock in CmmExpr (see comment there) -- - invariant on CmmBlock in CmmExpr (see comment there)
...@@ -212,9 +213,7 @@ checkCond _ expr ...@@ -212,9 +213,7 @@ checkCond _ expr
-- just a basic error monad: -- just a basic error monad:
newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a } newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
deriving (Functor)
instance Functor CmmLint where
fmap = liftM
instance Applicative CmmLint where instance Applicative CmmLint where
pure a = CmmLint (\_ -> Right a) pure a = CmmLint (\_ -> Right a)
......
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
module Hoopl.Block module Hoopl.Block
( C ( C
, O , O
...@@ -64,14 +66,8 @@ data MaybeC ex t where ...@@ -64,14 +66,8 @@ data MaybeC ex t where
JustC :: t -> MaybeC C t JustC :: t -> MaybeC C t
NothingC :: MaybeC O t NothingC :: MaybeC O t
deriving instance Functor (MaybeO ex)
instance Functor (MaybeO ex) where deriving instance Functor (MaybeC ex)
fmap _ NothingO = NothingO
fmap f (JustO a) = JustO (f a)
instance Functor (MaybeC ex) where
fmap _ NothingC = NothingC
fmap f (JustC a) = JustC (f a)
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- The Block type -- The Block type
......
{-# LANGUAGE CPP, GADTs #-} {-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
...@@ -61,7 +61,7 @@ import Data.Map (Map) ...@@ -61,7 +61,7 @@ import Data.Map (Map)
import Data.Word import Data.Word
import System.IO import System.IO
import qualified Data.Map as Map import qualified Data.Map as Map
import Control.Monad (liftM, ap) import Control.Monad (ap)
import qualified Data.Array.Unsafe as U ( castSTUArray ) import qualified Data.Array.Unsafe as U ( castSTUArray )
import Data.Array.ST import Data.Array.ST
...@@ -1082,10 +1082,7 @@ pprExternDecl lbl ...@@ -1082,10 +1082,7 @@ pprExternDecl lbl
<> semi <> semi
type TEState = (UniqSet LocalReg, Map CLabel ()) type TEState = (UniqSet LocalReg, Map CLabel ())
newtype TE a = TE { unTE :: TEState -> (a, TEState) } newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor)
instance Functor TE where
fmap = liftM
instance Applicative TE where instance Applicative TE where
pure a = TE $ \s -> (a, s) pure a = TE $ \s -> (a, s)
......
{-# LANGUAGE DeriveFunctor #-}
-- | Our extended FCode monad. -- | Our extended FCode monad.
-- We add a mapping from names to CmmExpr, to support local variable names in -- We add a mapping from names to CmmExpr, to support local variable names in
...@@ -53,7 +54,7 @@ import UniqFM ...@@ -53,7 +54,7 @@ import UniqFM
import Unique import Unique
import UniqSupply import UniqSupply
import Control.Monad (liftM, ap) import Control.Monad (ap)
-- | The environment contains variable definitions or blockids. -- | The environment contains variable definitions or blockids.
data Named data Named
...@@ -73,6 +74,7 @@ type Decls = [(FastString,Named)] ...@@ -73,6 +74,7 @@ type Decls = [(FastString,Named)]
-- and a list of local declarations. Returns the resulting list of declarations. -- and a list of local declarations. Returns the resulting list of declarations.
newtype CmmParse a newtype CmmParse a
= EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) } = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
deriving (Functor)
type ExtCode = CmmParse () type ExtCode = CmmParse ()
...@@ -82,9 +84,6 @@ returnExtFC a = EC $ \_ _ s -> return (s, a) ...@@ -82,9 +84,6 @@ returnExtFC a = EC $ \_ _ s -> return (s, a)
thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s' thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'
instance Functor CmmParse where
fmap = liftM
instance Applicative CmmParse where instance Applicative CmmParse where
pure = returnExtFC pure = returnExtFC
(<*>) = ap (<*>) = ap
......
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
...@@ -111,9 +112,7 @@ import Data.List ...@@ -111,9 +112,7 @@ import Data.List
-------------------------------------------------------- --------------------------------------------------------
newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }
deriving (Functor)
instance Functor FCode where
fmap f (FCode g) = FCode $ \i s -> case g i s of (a, s') -> (f a, s')
instance Applicative FCode where instance Applicative FCode where
pure val = FCode (\_info_down state -> (val, state)) pure val = FCode (\_info_down state -> (val, state))
......
...@@ -7,6 +7,7 @@ A ``lint'' pass to check for Core correctness ...@@ -7,6 +7,7 @@ A ``lint'' pass to check for Core correctness
-} -}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
module CoreLint ( module CoreLint (
lintCoreBindings, lintUnfolding, lintCoreBindings, lintUnfolding,
...@@ -2076,6 +2077,7 @@ newtype LintM a = ...@@ -2076,6 +2077,7 @@ newtype LintM a =
LintEnv -> LintEnv ->
WarnsAndErrs -> -- Warning and error messages so far WarnsAndErrs -> -- Warning and error messages so far
(Maybe a, WarnsAndErrs) } -- Result and messages (if any) (Maybe a, WarnsAndErrs) } -- Result and messages (if any)
deriving (Functor)
type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
...@@ -2146,9 +2148,6 @@ we behave as follows (#15057, #T15664): ...@@ -2146,9 +2148,6 @@ we behave as follows (#15057, #T15664):
when the type is expanded. when the type is expanded.
-} -}
instance Functor LintM where
fmap = liftM
instance Applicative LintM where instance Applicative LintM where
pure x = LintM $ \ _ errs -> (Just x, errs) pure x = LintM $ \ _ errs -> (Just x, errs)
(<*>) = ap (<*>) = ap
......
...@@ -6,6 +6,7 @@ ...@@ -6,6 +6,7 @@
{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-} {-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
module Coverage (addTicksToBinds, hpcInitCode) where module Coverage (addTicksToBinds, hpcInitCode) where
...@@ -1071,12 +1072,10 @@ noFVs = emptyOccEnv ...@@ -1071,12 +1072,10 @@ noFVs = emptyOccEnv
-- over what free variables we track. -- over what free variables we track.
data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
deriving (Functor)
-- a combination of a state monad (TickTransState) and a writer -- a combination of a state monad (TickTransState) and a writer
-- monad (FreeVars). -- monad (FreeVars).
instance Functor TM where
fmap = liftM
instance Applicative TM where instance Applicative TM where
pure a = TM $ \ _env st -> (a,noFVs,st) pure a = TM $ \ _env st -> (a,noFVs,st)
(<*>) = ap (<*>) = ap
......
{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-} {-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
-- --
-- (c) The University of Glasgow 2002-2006 -- (c) The University of Glasgow 2002-2006
...@@ -224,9 +224,7 @@ data Assembler a ...@@ -224,9 +224,7 @@ data Assembler a
| AllocLabel Word16 (Assembler a) | AllocLabel Word16 (Assembler a)
| Emit Word16 [Operand] (Assembler a) | Emit Word16 [Operand] (Assembler a)
| NullAsm a | NullAsm a
deriving (Functor)
instance Functor Assembler where
fmap = liftM
instance Applicative Assembler where instance Applicative Assembler where
pure = NullAsm pure = NullAsm
......
{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} {-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fprof-auto-top #-} {-# OPTIONS_GHC -fprof-auto-top #-}
-- --
...@@ -1861,7 +1862,7 @@ data BcM_State ...@@ -1861,7 +1862,7 @@ data BcM_State
-- See Note [generating code for top-level string literal bindings]. -- See Note [generating code for top-level string literal bindings].
} }
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)
ioToBc :: IO a -> BcM a ioToBc :: IO a -> BcM a
ioToBc io = BcM $ \st -> do ioToBc io = BcM $ \st -> do
...@@ -1891,9 +1892,6 @@ thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do ...@@ -1891,9 +1892,6 @@ thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
returnBc :: a -> BcM a returnBc :: a -> BcM a
returnBc result = BcM $ \st -> (return (st, result)) returnBc result = BcM $ \st -> (return (st, result))
instance Functor BcM where
fmap = liftM
instance Applicative BcM where instance Applicative BcM where
pure = returnBc pure = returnBc
(<*>) = ap (<*>) = ap
......
...@@ -6,6 +6,7 @@ ...@@ -6,6 +6,7 @@
This module converts Template Haskell syntax into HsSyn This module converts Template Haskell syntax into HsSyn
-} -}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
...@@ -40,7 +41,7 @@ import Outputable ...@@ -40,7 +41,7 @@ import Outputable
import MonadUtils ( foldrM ) import MonadUtils ( foldrM )
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Control.Monad( unless, liftM, ap ) import Control.Monad( unless, ap )
import Data.Maybe( catMaybes, isNothing ) import Data.Maybe( catMaybes, isNothing )
import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH as TH hiding (sigP)
...@@ -71,6 +72,7 @@ convertToHsType loc t ...@@ -71,6 +72,7 @@ convertToHsType loc t
------------------------------------------------------------------- -------------------------------------------------------------------
newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) } newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
deriving (Functor)
-- Push down the source location; -- Push down the source location;
-- Can fail, with a single error message -- Can fail, with a single error message
...@@ -83,9 +85,6 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) } ...@@ -83,9 +85,6 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
-- In particular, we want it on binding locations, so that variables bound in -- In particular, we want it on binding locations, so that variables bound in
-- the spliced-in declarations get a location that at least relates to the splice point -- the spliced-in declarations get a location that at least relates to the splice point
instance Functor CvtM where
fmap = liftM
instance Applicative CvtM where instance Applicative CvtM where
pure x = CvtM $ \loc -> Right (loc,x) pure x = CvtM $ \loc -> Right (loc,x)
(<*>) = ap (<*>) = ap
......
...@@ -8,6 +8,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. ...@@ -8,6 +8,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
-} -}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
...@@ -1262,7 +1263,7 @@ data RecordPatSynField a ...@@ -1262,7 +1263,7 @@ data RecordPatSynField a
, recordPatSynPatVar :: a , recordPatSynPatVar :: a
-- Filled in by renamer, the name used internally -- Filled in by renamer, the name used internally
-- by the pattern -- by the pattern
} deriving Data } deriving (Data, Functor)
...@@ -1287,12 +1288,6 @@ when we have a different name for the local and top-level binder ...@@ -1287,12 +1288,6 @@ when we have a different name for the local and top-level binder
the distinction between the two names clear the distinction between the two names clear
-} -}
instance Functor RecordPatSynField where
fmap f (RecordPatSynField { recordPatSynSelectorId = visible
, recordPatSynPatVar = hidden })
= RecordPatSynField { recordPatSynSelectorId = f visible
, recordPatSynPatVar = f hidden }
instance Outputable a => Outputable (RecordPatSynField a) where instance Outputable a => Outputable (RecordPatSynField a) where
ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v
......
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- | Base LLVM Code Generation module -- | Base LLVM Code Generation module
...@@ -209,10 +210,7 @@ type LlvmEnvMap = UniqFM LlvmType ...@@ -209,10 +210,7 @@ type LlvmEnvMap = UniqFM LlvmType
-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
deriving (Functor)
instance Functor LlvmM where
fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
return (f x, env')
instance Applicative LlvmM where instance Applicative LlvmM where
pure x = LlvmM $ \env -> return (x, env) pure x = LlvmM $ \env -> return (x, env)
......
...@@ -4,6 +4,7 @@ ...@@ -4,6 +4,7 @@
-- (c) The University of Glasgow 2006 -- (c) The University of Glasgow 2006
-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-- --
{-# LANGUAGE DeriveFunctor #-}
module Annotations ( module Annotations (
-- * Main Annotation data types -- * Main Annotation data types
Annotation(..), AnnPayload, Annotation(..), AnnPayload,
...@@ -49,14 +50,11 @@ data AnnTarget name ...@@ -49,14 +50,11 @@ data AnnTarget name
= NamedTarget name -- ^ We are annotating something with a name: = NamedTarget name -- ^ We are annotating something with a name:
-- a type or identifier -- a type or identifier
| ModuleTarget Module -- ^ We are annotating a particular module | ModuleTarget Module -- ^ We are annotating a particular module
deriving (Functor)
-- | The kind of annotation target found in the middle end of the compiler -- | The kind of annotation target found in the middle end of the compiler
type CoreAnnTarget = AnnTarget Name type CoreAnnTarget = AnnTarget Name
instance Functor AnnTarget where
fmap f (NamedTarget nm) = NamedTarget (f nm)
fmap _ (ModuleTarget mod) = ModuleTarget mod
-- | Get the 'name' of an annotation target if it exists. -- | Get the 'name' of an annotation target if it exists.
getAnnTargetName_maybe :: AnnTarget name -> Maybe name getAnnTargetName_maybe :: AnnTarget name -> Maybe name
getAnnTargetName_maybe (NamedTarget nm) = Just nm getAnnTargetName_maybe (NamedTarget nm) = Just nm
......
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- --
...@@ -166,9 +167,7 @@ liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) ...@@ -166,9 +167,7 @@ liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) -- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
deriving (Functor)
instance Functor (CmdLineP s) where
fmap = liftM
instance Applicative (CmdLineP s) where instance Applicative (CmdLineP s) where
pure a = CmdLineP $ \s -> (a, s) pure a = CmdLineP $ \s -> (a, s)
......
{-# LANGUAGE CPP, RankNTypes #-} {-# LANGUAGE CPP, DeriveFunctor, RankNTypes #-}
{-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_GHC -funbox-strict-fields #-}
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- --
...@@ -90,7 +90,7 @@ logWarnings warns = do ...@@ -90,7 +90,7 @@ logWarnings warns = do
-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
-- e.g., to maintain additional state consider wrapping this monad or using -- e.g., to maintain additional state consider wrapping this monad or using
-- 'GhcT'. -- 'GhcT'.
newtype Ghc a = Ghc { unGhc :: Session -> IO a } newtype Ghc a = Ghc { unGhc :: Session -> IO a } deriving (Functor)
-- | The Session is a handle to the complete state of a compilation -- | The Session is a handle to the complete state of a compilation
-- session. A compilation session consists of a set of modules -- session. A compilation session consists of a set of modules
...@@ -98,9 +98,6 @@ newtype Ghc a = Ghc { unGhc :: Session -> IO a } ...@@ -98,9 +98,6 @@ newtype Ghc a = Ghc { unGhc :: Session -> IO a }
-- interactive evaluation, and various caches. -- interactive evaluation, and various caches.
data Session = Session !(IORef HscEnv) data Session = Session !(IORef HscEnv)
instance Functor Ghc where
fmap f m = Ghc $ \s -> f `fmap` unGhc m s
instance Applicative Ghc where instance Applicative Ghc where
pure a = Ghc $ \_ -> return a pure a = Ghc $ \_ -> return a
g <*> m = do f <- g; a <- m; return (f a) g <*> m = do f <- g; a <- m; return (f a)
...@@ -158,13 +155,11 @@ reifyGhc act = Ghc $ act ...@@ -158,13 +155,11 @@ reifyGhc act = Ghc $ act
-- --
-- Note that the wrapped monad must support IO and handling of exceptions. -- Note that the wrapped monad must support IO and handling of exceptions.
newtype GhcT m a = GhcT { unGhcT :: Session -> m a } newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
deriving (Functor)
liftGhcT :: m a -> GhcT m a liftGhcT :: m a -> GhcT m a
liftGhcT m = GhcT $ \_ -> m liftGhcT m = GhcT $ \_ -> m
instance Functor m => Functor (GhcT m) where
fmap f m = GhcT $ \s -> f `fmap` unGhcT m s
instance Applicative m => Applicative (GhcT m) where instance Applicative m => Applicative (GhcT m) where
pure x = GhcT $ \_ -> pure x pure x = GhcT $ \_ -> pure x
g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s
......
...@@ -5,6 +5,7 @@ ...@@ -5,6 +5,7 @@
-} -}
{-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}