summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>2019-06-08 20:48:07 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-06-12 07:37:12 -0400
commit1219f8e8a3d1b58263bea76822322b746a632778 (patch)
treebd93bdf1e09cd26a7c6104ba37c6734a74e8a7bc
parent217e6db4af6752b13c586d4e8925a4a9a2f47245 (diff)
downloadhaskell-1219f8e8a3d1b58263bea76822322b746a632778.tar.gz
Use DeriveFunctor throughout the codebase (#15654)
-rw-r--r--compiler/basicTypes/UniqSupply.hs7
-rw-r--r--compiler/cmm/CmmLint.hs7
-rw-r--r--compiler/cmm/Hoopl/Block.hs12
-rw-r--r--compiler/cmm/PprC.hs9
-rw-r--r--compiler/codeGen/StgCmmExtCode.hs7
-rw-r--r--compiler/codeGen/StgCmmMonad.hs5
-rw-r--r--compiler/coreSyn/CoreLint.hs5
-rw-r--r--compiler/deSugar/Coverage.hs5
-rw-r--r--compiler/ghci/ByteCodeAsm.hs6
-rw-r--r--compiler/ghci/ByteCodeGen.hs6
-rw-r--r--compiler/hsSyn/Convert.hs7
-rw-r--r--compiler/hsSyn/HsBinds.hs9
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Base.hs6
-rw-r--r--compiler/main/Annotations.hs6
-rw-r--r--compiler/main/CmdLineParser.hs5
-rw-r--r--compiler/main/GhcMonad.hs11
-rw-r--r--compiler/main/HscTypes.hs5
-rw-r--r--compiler/main/PipelineMonad.hs5
-rw-r--r--compiler/main/TidyPgm.hs6
-rw-r--r--compiler/nativeGen/AsmCodeGen.hs9
-rw-r--r--compiler/nativeGen/NCGMonad.hs7
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/State.hs9
-rw-r--r--compiler/prelude/PrelRules.hs7
-rw-r--r--compiler/rename/RnPat.hs7
-rw-r--r--compiler/simplCore/CoreMonad.hs5
-rw-r--r--compiler/simplCore/SimplMonad.hs7
-rw-r--r--compiler/specialise/Specialise.hs6
-rw-r--r--compiler/stgSyn/CoreToStg.hs8
-rw-r--r--compiler/stgSyn/StgLint.hs7
-rw-r--r--compiler/typecheck/TcCanonical.hs6
-rw-r--r--compiler/typecheck/TcFlatten.hs6
-rw-r--r--compiler/typecheck/TcRnTypes.hs9
-rw-r--r--compiler/typecheck/TcSMonad.hs7
-rw-r--r--compiler/typecheck/TcTyDecls.hs9
-rw-r--r--compiler/typecheck/TcUnify.hs7
-rw-r--r--compiler/types/FamInstEnv.hs6
-rw-r--r--compiler/types/Unify.hs4
-rw-r--r--compiler/utils/Bag.hs11
-rw-r--r--compiler/utils/IOEnv.hs6
-rw-r--r--compiler/utils/ListT.hs5
-rw-r--r--compiler/utils/Maybes.hs5
-rw-r--r--compiler/utils/OrdList.hs12
-rw-r--r--compiler/utils/Pair.hs4
-rw-r--r--compiler/utils/State.hs6
-rw-r--r--compiler/utils/UniqDFM.hs5
-rw-r--r--ghc/GHCi/UI/Monad.hs6
46 files changed, 114 insertions, 201 deletions
diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs
index 8780a52208..9697566efc 100644
--- a/compiler/basicTypes/UniqSupply.hs
+++ b/compiler/basicTypes/UniqSupply.hs
@@ -4,6 +4,7 @@
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
#if !defined(GHC_LOADED_INTO_GHCI)
@@ -148,20 +149,18 @@ pattern UniqResult x y = (# x, y #)
#else
data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply
+ deriving (Functor)
#endif
-- | A monad which just gives the ability to obtain 'Unique's
newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }
+ deriving (Functor)
instance Monad UniqSM where
(>>=) = 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
pure = returnUs
(USM f) <*> (USM x) = USM $ \us0 -> case f us0 of
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 3224bb8cab..d5c3f84443 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -5,6 +5,7 @@
-- CmmLint: checking the correctness of Cmm statements and expressions
--
-----------------------------------------------------------------------------
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
module CmmLint (
cmmLint, cmmLintGraph
@@ -24,7 +25,7 @@ import PprCmm ()
import Outputable
import DynFlags
-import Control.Monad (liftM, ap)
+import Control.Monad (ap)
-- Things to check:
-- - invariant on CmmBlock in CmmExpr (see comment there)
@@ -212,9 +213,7 @@ checkCond _ expr
-- just a basic error monad:
newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
-
-instance Functor CmmLint where
- fmap = liftM
+ deriving (Functor)
instance Applicative CmmLint where
pure a = CmmLint (\_ -> Right a)
diff --git a/compiler/cmm/Hoopl/Block.hs b/compiler/cmm/Hoopl/Block.hs
index c4ff1794e8..5c31932934 100644
--- a/compiler/cmm/Hoopl/Block.hs
+++ b/compiler/cmm/Hoopl/Block.hs
@@ -1,7 +1,9 @@
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE StandaloneDeriving #-}
module Hoopl.Block
( C
, O
@@ -64,14 +66,8 @@ data MaybeC ex t where
JustC :: t -> MaybeC C t
NothingC :: MaybeC O t
-
-instance Functor (MaybeO ex) where
- 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)
+deriving instance Functor (MaybeO ex)
+deriving instance Functor (MaybeC ex)
-- -----------------------------------------------------------------------------
-- The Block type
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index bacdc9face..e57c409a04 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GADTs #-}
+{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}
-----------------------------------------------------------------------------
--
@@ -61,7 +61,7 @@ import Data.Map (Map)
import Data.Word
import System.IO
import qualified Data.Map as Map
-import Control.Monad (liftM, ap)
+import Control.Monad (ap)
import qualified Data.Array.Unsafe as U ( castSTUArray )
import Data.Array.ST
@@ -1082,10 +1082,7 @@ pprExternDecl lbl
<> semi
type TEState = (UniqSet LocalReg, Map CLabel ())
-newtype TE a = TE { unTE :: TEState -> (a, TEState) }
-
-instance Functor TE where
- fmap = liftM
+newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor)
instance Applicative TE where
pure a = TE $ \s -> (a, s)
diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
index 551535d758..1d35c3454e 100644
--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveFunctor #-}
-- | Our extended FCode monad.
-- We add a mapping from names to CmmExpr, to support local variable names in
@@ -53,7 +54,7 @@ import UniqFM
import Unique
import UniqSupply
-import Control.Monad (liftM, ap)
+import Control.Monad (ap)
-- | The environment contains variable definitions or blockids.
data Named
@@ -73,6 +74,7 @@ type Decls = [(FastString,Named)]
-- and a list of local declarations. Returns the resulting list of declarations.
newtype CmmParse a
= EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
+ deriving (Functor)
type ExtCode = CmmParse ()
@@ -82,9 +84,6 @@ returnExtFC a = EC $ \_ _ s -> return (s, a)
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'
-instance Functor CmmParse where
- fmap = liftM
-
instance Applicative CmmParse where
pure = returnExtFC
(<*>) = ap
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 8be5c4551f..d6f84c6a0a 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
@@ -111,9 +112,7 @@ import Data.List
--------------------------------------------------------
newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }
-
-instance Functor FCode where
- fmap f (FCode g) = FCode $ \i s -> case g i s of (a, s') -> (f a, s')
+ deriving (Functor)
instance Applicative FCode where
pure val = FCode (\_info_down state -> (val, state))
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index ef4e858568..91760c282b 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -7,6 +7,7 @@ A ``lint'' pass to check for Core correctness
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
module CoreLint (
lintCoreBindings, lintUnfolding,
@@ -2076,6 +2077,7 @@ newtype LintM a =
LintEnv ->
WarnsAndErrs -> -- Warning and error messages so far
(Maybe a, WarnsAndErrs) } -- Result and messages (if any)
+ deriving (Functor)
type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
@@ -2146,9 +2148,6 @@ we behave as follows (#15057, #T15664):
when the type is expanded.
-}
-instance Functor LintM where
- fmap = liftM
-
instance Applicative LintM where
pure x = LintM $ \ _ errs -> (Just x, errs)
(<*>) = ap
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index d140829544..59b8bcfc78 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveFunctor #-}
module Coverage (addTicksToBinds, hpcInitCode) where
@@ -1071,12 +1072,10 @@ noFVs = emptyOccEnv
-- over what free variables we track.
data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
+ deriving (Functor)
-- a combination of a state monad (TickTransState) and a writer
-- monad (FreeVars).
-instance Functor TM where
- fmap = liftM
-
instance Applicative TM where
pure a = TM $ \ _env st -> (a,noFVs,st)
(<*>) = ap
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index 0776e406d6..fb38ca1c02 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-}
+{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -224,9 +224,7 @@ data Assembler a
| AllocLabel Word16 (Assembler a)
| Emit Word16 [Operand] (Assembler a)
| NullAsm a
-
-instance Functor Assembler where
- fmap = liftM
+ deriving (Functor)
instance Applicative Assembler where
pure = NullAsm
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index c4a08c4e40..33ae172d71 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
--
@@ -1861,7 +1862,7 @@ data BcM_State
-- 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 = BcM $ \st -> do
@@ -1891,9 +1892,6 @@ thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
returnBc :: a -> BcM a
returnBc result = BcM $ \st -> (return (st, result))
-instance Functor BcM where
- fmap = liftM
-
instance Applicative BcM where
pure = returnBc
(<*>) = ap
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 2292a9fea4..b4be2f0000 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -6,6 +6,7 @@
This module converts Template Haskell syntax into HsSyn
-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
@@ -40,7 +41,7 @@ import Outputable
import MonadUtils ( foldrM )
import qualified Data.ByteString as BS
-import Control.Monad( unless, liftM, ap )
+import Control.Monad( unless, ap )
import Data.Maybe( catMaybes, isNothing )
import Language.Haskell.TH as TH hiding (sigP)
@@ -71,6 +72,7 @@ convertToHsType loc t
-------------------------------------------------------------------
newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
+ deriving (Functor)
-- Push down the source location;
-- Can fail, with a single error message
@@ -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
-- 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
pure x = CvtM $ \loc -> Right (loc,x)
(<*>) = ap
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 8e3448d0f0..1763c3f2de 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -8,6 +8,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
@@ -1262,7 +1263,7 @@ data RecordPatSynField a
, recordPatSynPatVar :: a
-- Filled in by renamer, the name used internally
-- 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
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
ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index d55c339888..ab9695778c 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
-- ----------------------------------------------------------------------------
-- | Base LLVM Code Generation module
@@ -209,10 +210,7 @@ type LlvmEnvMap = UniqFM LlvmType
-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
-
-instance Functor LlvmM where
- fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
- return (f x, env')
+ deriving (Functor)
instance Applicative LlvmM where
pure x = LlvmM $ \env -> return (x, env)
diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs
index f6d5a1cb12..82d80aae43 100644
--- a/compiler/main/Annotations.hs
+++ b/compiler/main/Annotations.hs
@@ -4,6 +4,7 @@
-- (c) The University of Glasgow 2006
-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--
+{-# LANGUAGE DeriveFunctor #-}
module Annotations (
-- * Main Annotation data types
Annotation(..), AnnPayload,
@@ -49,14 +50,11 @@ data AnnTarget name
= NamedTarget name -- ^ We are annotating something with a name:
-- a type or identifier
| ModuleTarget Module -- ^ We are annotating a particular module
+ deriving (Functor)
-- | The kind of annotation target found in the middle end of the compiler
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.
getAnnTargetName_maybe :: AnnTarget name -> Maybe name
getAnnTargetName_maybe (NamedTarget nm) = Just nm
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 6763aed128..d2cc56f033 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
-------------------------------------------------------------------------------
--
@@ -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)
newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
-
-instance Functor (CmdLineP s) where
- fmap = liftM
+ deriving (Functor)
instance Applicative (CmdLineP s) where
pure a = CmdLineP $ \s -> (a, s)
diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
index f72cacc7ef..846744c439 100644
--- a/compiler/main/GhcMonad.hs
+++ b/compiler/main/GhcMonad.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, RankNTypes #-}
+{-# LANGUAGE CPP, DeriveFunctor, RankNTypes #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
-- -----------------------------------------------------------------------------
--
@@ -90,7 +90,7 @@ logWarnings warns = do
-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
-- e.g., to maintain additional state consider wrapping this monad or using
-- '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
-- session. A compilation session consists of a set of modules
@@ -98,9 +98,6 @@ newtype Ghc a = Ghc { unGhc :: Session -> IO a }
-- interactive evaluation, and various caches.
data Session = Session !(IORef HscEnv)
-instance Functor Ghc where
- fmap f m = Ghc $ \s -> f `fmap` unGhc m s
-
instance Applicative Ghc where
pure a = Ghc $ \_ -> return a
g <*> m = do f <- g; a <- m; return (f a)
@@ -158,13 +155,11 @@ reifyGhc act = Ghc $ act
--
-- Note that the wrapped monad must support IO and handling of exceptions.
newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
+ deriving (Functor)
liftGhcT :: m a -> GhcT m a
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
pure x = GhcT $ \_ -> pure x
g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index eb9877b096..2749073ff1 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -5,6 +5,7 @@
-}
{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
@@ -231,9 +232,7 @@ data HscStatus
-- The Hsc monad: Passing an environment and warning state
newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
-
-instance Functor Hsc where
- fmap = liftM
+ deriving (Functor)
instance Applicative Hsc where
pure a = Hsc $ \_ w -> return (a, w)
diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs
index bbb1a17b65..d152d04530 100644
--- a/compiler/main/PipelineMonad.hs
+++ b/compiler/main/PipelineMonad.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE NamedFieldPuns #-}
-- | The CompPipeline monad and associated ops
--
@@ -22,13 +23,11 @@ import FileCleanup (TempFileLifetime)
import Control.Monad
newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
+ deriving (Functor)
evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
evalP f env st = liftM snd $ unP f env st
-instance Functor CompPipeline where
- fmap = liftM
-
instance Applicative CompPipeline where
pure a = P $ \_env state -> return (state, a)
(<*>) = ap
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index d0e813a403..4f9c8c856f 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -4,7 +4,7 @@
\section{Tidying up Core}
-}
-{-# LANGUAGE CPP, ViewPatterns #-}
+{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-}
module TidyPgm (
mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
@@ -751,9 +751,7 @@ newtype DFFV a
-- we don't want to record these as free vars
-> (VarSet, [Var]) -- Input State: (set, list) of free vars so far
-> ((VarSet,[Var]),a)) -- Output state
-
-instance Functor DFFV where
- fmap = liftM
+ deriving (Functor)
instance Applicative DFFV where
pure a = DFFV $ \_ st -> (st, a)
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index cc608b1ec6..ed0c57e1e2 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -6,7 +6,8 @@
--
-- -----------------------------------------------------------------------------
-{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms #-}
+{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms,
+ DeriveFunctor #-}
#if !defined(GHC_LOADED_INTO_GHCI)
{-# LANGUAGE UnboxedTuples #-}
@@ -1038,13 +1039,11 @@ pattern OptMResult x y = (# x, y #)
{-# COMPLETE OptMResult #-}
#else
-data OptMResult a = OptMResult !a ![CLabel]
+data OptMResult a = OptMResult !a ![CLabel] deriving (Functor)
#endif
newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a)
-
-instance Functor CmmOptM where
- fmap = liftM
+ deriving (Functor)
instance Applicative CmmOptM where
pure x = CmmOptM $ \_ _ imports -> OptMResult x imports
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index 0f53ef6690..3680c1c7b0 100644
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
-- -----------------------------------------------------------------------------
--
@@ -59,7 +60,7 @@ import Unique ( Unique )
import DynFlags
import Module
-import Control.Monad ( liftM, ap )
+import Control.Monad ( ap )
import Instruction
import Outputable (SDoc, pprPanic, ppr)
@@ -113,6 +114,7 @@ data NatM_State
type DwarfFiles = UniqFM (FastString, Int)
newtype NatM result = NatM (NatM_State -> (result, NatM_State))
+ deriving (Functor)
unNat :: NatM a -> NatM_State -> (a, NatM_State)
unNat (NatM a) = a
@@ -138,9 +140,6 @@ initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m
= case unNat m init_st of { (r,st) -> (r,st) }
-instance Functor NatM where
- fmap = liftM
-
instance Applicative NatM where
pure = returnNat
(<*>) = ap
diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs
index 8df4dd04f0..43b8f6c129 100644
--- a/compiler/nativeGen/RegAlloc/Linear/State.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/State.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, PatternSynonyms #-}
+{-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-}
#if !defined(GHC_LOADED_INTO_GHCI)
{-# LANGUAGE UnboxedTuples #-}
@@ -50,7 +50,7 @@ import DynFlags
import Unique
import UniqSupply
-import Control.Monad (liftM, ap)
+import Control.Monad (ap)
-- Avoids using unboxed tuples when loading into GHCi
#if !defined(GHC_LOADED_INTO_GHCI)
@@ -63,15 +63,14 @@ pattern RA_Result a b = (# a, b #)
#else
data RA_Result freeRegs a = RA_Result {-# UNPACK #-} !(RA_State freeRegs) !a
+ deriving (Functor)
#endif
-- | The register allocator monad type.
newtype RegM freeRegs a
= RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
-
-instance Functor (RegM freeRegs) where
- fmap = liftM
+ deriving (Functor)
instance Applicative (RegM freeRegs) where
pure a = RegM $ \s -> RA_Result s a
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index bd18bfec63..63a8c9d48a 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -12,7 +12,8 @@ ToDo:
(i1 + i2) only if it results in a valid Float.
-}
-{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards #-}
+{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards,
+ DeriveFunctor #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
module PrelRules
@@ -739,9 +740,7 @@ mkBasicRule op_name n_args rm
newtype RuleM r = RuleM
{ runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
-
-instance Functor RuleM where
- fmap = liftM
+ deriving (Functor)
instance Applicative RuleM where
pure x = RuleM $ \_ _ _ -> Just x
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index ca8c665e28..4a08ab4761 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -16,6 +16,7 @@ free variables.
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveFunctor #-}
module RnPat (-- main entry points
rnPat, rnPats, rnBindPat, rnPatAndThen,
@@ -72,7 +73,7 @@ import TysWiredIn ( nilDataCon )
import DataCon
import qualified GHC.LanguageExtensions as LangExt
-import Control.Monad ( when, liftM, ap, guard )
+import Control.Monad ( when, ap, guard )
import qualified Data.List.NonEmpty as NE
import Data.Ratio
@@ -107,11 +108,9 @@ p1 scope over p2,p3.
newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
-> RnM (r, FreeVars) }
+ deriving (Functor)
-- See Note [CpsRn monad]
-instance Functor CpsRn where
- fmap = liftM
-
instance Applicative CpsRn where
pure x = CpsRn (\k -> k x)
(<*>) = ap
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index 3a2277a7a7..29e4b00c4d 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -5,6 +5,7 @@
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
module CoreMonad (
-- * Configuration of the core-to-core passes
@@ -582,9 +583,7 @@ type CoreIOEnv = IOEnv CoreReader
-- | The monad used by Core-to-Core passes to access common state, register simplification
-- statistics and so on
newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
-
-instance Functor CoreM where
- fmap = liftM
+ deriving (Functor)
instance Monad CoreM where
mx >>= f = CoreM $ \s -> do
diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs
index c28f99f9dd..732805e9ee 100644
--- a/compiler/simplCore/SimplMonad.hs
+++ b/compiler/simplCore/SimplMonad.hs
@@ -4,6 +4,7 @@
\section[SimplMonad]{The simplifier Monad}
-}
+{-# LANGUAGE DeriveFunctor #-}
module SimplMonad (
-- The monad
SimplM,
@@ -37,7 +38,7 @@ import MonadUtils
import ErrUtils as Err
import Panic (throwGhcExceptionIO, GhcException (..))
import BasicTypes ( IntWithInf, treatZeroAsInf, mkIntWithInf )
-import Control.Monad ( liftM, ap )
+import Control.Monad ( ap )
{-
************************************************************************
@@ -57,6 +58,7 @@ newtype SimplM result
-> SimplCount
-> IO (result, UniqSupply, SimplCount)}
-- we only need IO here for dump output
+ deriving (Functor)
data SimplTopEnv
= STE { st_flags :: DynFlags
@@ -104,9 +106,6 @@ computeMaxTicks dflags size
{-# INLINE returnSmpl #-}
-instance Functor SimplM where
- fmap = liftM
-
instance Applicative SimplM where
pure = returnSmpl
(<*>) = ap
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index ed2ae073e9..3434172de2 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -5,6 +5,7 @@
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}
module Specialise ( specProgram, specUnfolding ) where
@@ -2530,7 +2531,7 @@ deleteCallsFor bs calls = delDVarEnvList calls bs
************************************************************************
-}
-newtype SpecM a = SpecM (State SpecState a)
+newtype SpecM a = SpecM (State SpecState a) deriving (Functor)
data SpecState = SpecState {
spec_uniq_supply :: UniqSupply,
@@ -2538,9 +2539,6 @@ data SpecState = SpecState {
spec_dflags :: DynFlags
}
-instance Functor SpecM where
- fmap = liftM
-
instance Applicative SpecM where
pure x = SpecM $ return x
(<*>) = ap
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 12766e90d4..3187298425 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, DeriveFunctor #-}
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
@@ -50,7 +50,7 @@ import SrcLoc ( mkGeneralSrcSpan )
import Data.List.NonEmpty (nonEmpty, toList)
import Data.Maybe (fromMaybe)
-import Control.Monad (liftM, ap)
+import Control.Monad (ap)
-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
@@ -813,6 +813,7 @@ newtype CtsM a = CtsM
{ unCtsM :: IdEnv HowBound
-> a
}
+ deriving (Functor)
data HowBound
= ImportBound -- Used only as a response to lookupBinding; never
@@ -861,9 +862,6 @@ thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
thenCts m k = CtsM $ \env
-> unCtsM (k (unCtsM m env)) env
-instance Functor CtsM where
- fmap = liftM
-
instance Applicative CtsM where
pure = returnCts
(<*>) = ap
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index c949f348f1..f83b44859c 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -32,7 +32,8 @@ Since then there were some attempts at enabling it again, as summarised in
basic properties listed above.
-}
-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,
+ DeriveFunctor #-}
module StgLint ( lintStgTopBindings ) where
@@ -258,6 +259,7 @@ newtype LintM a = LintM
-> Bag MsgDoc -- Error messages so far
-> (a, Bag MsgDoc) -- Result and error messages (if any)
}
+ deriving (Functor)
data LintFlags = LintFlags { lf_unarised :: !Bool
-- ^ have we run the unariser yet?
@@ -293,9 +295,6 @@ initL this_mod unarised locals (LintM m) = do
else
Just (vcat (punctuate blankLine (bagToList errs)))
-instance Functor LintM where
- fmap = liftM
-
instance Applicative LintM where
pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)
(<*>) = ap
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 9440d5ff0a..e0c87e0f70 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
module TcCanonical(
canonicalize,
@@ -2188,10 +2189,7 @@ data StopOrContinue a
| Stop CtEvidence -- The (rewritten) constraint was solved
SDoc -- Tells how it was solved
-- Any new sub-goals have been put on the work list
-
-instance Functor StopOrContinue where
- fmap f (ContinueWith x) = ContinueWith (f x)
- fmap _ (Stop ev s) = Stop ev s
+ deriving (Functor)
instance Outputable a => Outputable (StopOrContinue a) where
ppr (Stop ev s) = text "Stop" <> parens s <+> ppr ev
diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs
index 39a33f3fd7..2bb3d1c0e8 100644
--- a/compiler/typecheck/TcFlatten.hs
+++ b/compiler/typecheck/TcFlatten.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ViewPatterns, BangPatterns #-}
+{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-}
module TcFlatten(
FlattenMode(..),
@@ -485,15 +485,13 @@ eqFlattenMode _ _ = False
-- See Note [The flattening work list].
newtype FlatM a
= FlatM { runFlatM :: FlattenEnv -> TcS a }
+ deriving (Functor)
instance Monad FlatM where
m >>= k = FlatM $ \env ->
do { a <- runFlatM m env
; runFlatM (k a) env }
-instance Functor FlatM where
- fmap = liftM
-
instance Applicative FlatM where
pure x = FlatM $ const (pure x)
(<*>) = ap
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index bf98e0c2b1..221d9cea8c 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -16,7 +16,7 @@ For state that is global and should be returned at the end (e.g not part
of the stack mechanism), you should use a TcRef (= IORef) to store them.
-}
-{-# LANGUAGE CPP, ExistentialQuantification, GeneralizedNewtypeDeriving,
+{-# LANGUAGE CPP, DeriveFunctor, ExistentialQuantification, GeneralizedNewtypeDeriving,
ViewPatterns #-}
module TcRnTypes(
@@ -195,7 +195,7 @@ import Util
import PrelNames ( isUnboundName )
import CostCentreState
-import Control.Monad (ap, liftM, msum)
+import Control.Monad (ap, msum)
import qualified Control.Monad.Fail as MonadFail
import Data.Set ( Set )
import qualified Data.Set as S
@@ -3832,10 +3832,7 @@ type TcPluginSolver = [Ct] -- given
-> [Ct] -- wanted
-> TcPluginM TcPluginResult
-newtype TcPluginM a = TcPluginM (EvBindsVar -> TcM a)
-
-instance Functor TcPluginM where
- fmap = liftM
+newtype TcPluginM a = TcPluginM (EvBindsVar -> TcM a) deriving (Functor)
instance Applicative TcPluginM where
pure x = TcPluginM (const $ pure x)
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 8d98a17149..68496dfca6 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, TypeFamilies #-}
+{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-}
-- Type definitions for the constraint solver
module TcSMonad (
@@ -2601,10 +2601,7 @@ data TcSEnv
}
---------------
-newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
-
-instance Functor TcS where
- fmap f m = TcS $ fmap f . unTcS m
+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)
instance Applicative TcS where
pure x = TcS (\_ -> return x)
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 205771b2db..7a68fe1144 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -10,6 +10,7 @@ files for imported data types.
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
@@ -149,12 +150,10 @@ synonymTyConsOfType ty
-- a failure message reporting that a cycle was found.
newtype SynCycleM a = SynCycleM {
runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
+ deriving (Functor)
type SynCycleState = NameSet
-instance Functor SynCycleM where
- fmap = liftM
-
instance Applicative SynCycleM where
pure x = SynCycleM $ \state -> Right (x, state)
(<*>) = ap
@@ -677,9 +676,7 @@ newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon
-> Int -- size of VarPositions
-> RoleInferenceState
-> (a, RoleInferenceState) }
-
-instance Functor RoleM where
- fmap = liftM
+ deriving (Functor)
instance Applicative RoleM where
pure x = RM $ \_ _ _ state -> (x, state)
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index cbf98d888c..078ebecd54 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -6,7 +6,8 @@
Type subsumption and unification
-}
-{-# LANGUAGE CPP, MultiWayIf, TupleSections, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections,
+ ScopedTypeVariables #-}
module TcUnify (
-- Full-blown subsumption
@@ -2119,9 +2120,7 @@ data MetaTyVarUpdateResult a
= MTVU_OK a
| MTVU_Bad -- Forall, predicate, or type family
| MTVU_Occurs
-
-instance Functor MetaTyVarUpdateResult where
- fmap = liftM
+ deriving (Functor)
instance Applicative MetaTyVarUpdateResult where
pure = MTVU_OK
diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs
index 50d5bf41cc..cfe166c0b7 100644
--- a/compiler/types/FamInstEnv.hs
+++ b/compiler/types/FamInstEnv.hs
@@ -2,7 +2,8 @@
--
-- FamInstEnv: Type checked family instance declarations
-{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections #-}
+{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections,
+ DeriveFunctor #-}
module FamInstEnv (
FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,
@@ -1501,6 +1502,7 @@ normalise_var_bndr tcvar
-- a 'LiftingContext', and a 'Role'.
newtype NormM a = NormM { runNormM ::
FamInstEnvs -> LiftingContext -> Role -> a }
+ deriving (Functor)
initNormM :: FamInstEnvs -> Role
-> TyCoVarSet -- the in-scope variables
@@ -1531,8 +1533,6 @@ instance Monad NormM where
let a = runNormM ma env lc r in
runNormM (fmb a) env lc r
-instance Functor NormM where
- fmap = liftM
instance Applicative NormM where
pure x = NormM $ \ _ _ _ -> x
(<*>) = ap
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index 3bcf521603..b7ce569490 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -1206,9 +1206,7 @@ data UMState = UMState
, um_cv_env :: CvSubstEnv }
newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) }
-
-instance Functor UM where
- fmap = liftM
+ deriving (Functor)
instance Applicative UM where
pure a = UM (\s -> pure (s, a))
diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs
index 41c80390cc..2105eefc71 100644
--- a/compiler/utils/Bag.hs
+++ b/compiler/utils/Bag.hs
@@ -6,7 +6,7 @@
Bag: an unordered collection with duplicates
-}
-{-# LANGUAGE ScopedTypeVariables, CPP #-}
+{-# LANGUAGE ScopedTypeVariables, CPP, DeriveFunctor #-}
module Bag (
Bag, -- abstract type
@@ -45,6 +45,7 @@ data Bag a
| UnitBag a
| TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty
| ListBag [a] -- INVARIANT: the list is non-empty
+ deriving (Functor)
emptyBag :: Bag a
emptyBag = EmptyBag
@@ -221,10 +222,7 @@ foldlBagM k z (TwoBags b1 b2) = do { z' <- foldlBagM k z b1; foldlBagM k z' b2 }
foldlBagM k z (ListBag xs) = foldlM k z xs
mapBag :: (a -> b) -> Bag a -> Bag b
-mapBag _ EmptyBag = EmptyBag
-mapBag f (UnitBag x) = UnitBag (f x)
-mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2)
-mapBag f (ListBag xs) = ListBag (map f xs)
+mapBag = fmap
concatMapBag :: (a -> Bag b) -> Bag a -> Bag b
concatMapBag _ EmptyBag = EmptyBag
@@ -344,8 +342,5 @@ instance Data a => Data (Bag a) where
dataTypeOf _ = mkNoRepType "Bag"
dataCast1 x = gcast1 x
-instance Functor Bag where
- fmap = mapBag
-
instance Foldable.Foldable Bag where
foldr = foldrBag
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index d6807da71a..e62a2bcddf 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
--
-- (c) The University of Glasgow 2002-2006
--
@@ -51,7 +52,7 @@ import Control.Applicative (Alternative(..))
----------------------------------------------------------------------
-newtype IOEnv env a = IOEnv (env -> IO a)
+newtype IOEnv env a = IOEnv (env -> IO a) deriving (Functor)
unIOEnv :: IOEnv env a -> (env -> IO a)
unIOEnv (IOEnv m) = m
@@ -71,9 +72,6 @@ instance Applicative (IOEnv m) where
IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )
(*>) = thenM_
-instance Functor (IOEnv m) where
- fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env))
-
returnM :: a -> IOEnv env a
returnM a = IOEnv (\ _ -> return a)
diff --git a/compiler/utils/ListT.hs b/compiler/utils/ListT.hs
index 105e27b3d4..66e52ed9f4 100644
--- a/compiler/utils/ListT.hs
+++ b/compiler/utils/ListT.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -42,6 +43,7 @@ import Control.Monad.Fail as MonadFail
-- layered over another monad 'm'
newtype ListT m a =
ListT { unListT :: forall r. (a -> m r -> m r) -> m r -> m r }
+ deriving (Functor)
select :: Monad m => [a] -> ListT m a
select xs = foldr (<|>) mzero (map pure xs)
@@ -55,9 +57,6 @@ fold = runListT
runListT :: ListT m a -> (a -> m r -> m r) -> m r -> m r
runListT = unListT
-instance Functor (ListT f) where
- fmap f lt = ListT $ \sk fk -> unListT lt (sk . f) fk
-
instance Applicative (ListT f) where
pure a = ListT $ \sk fk -> sk a fk
f <*> a = ListT $ \sk fk -> unListT f (\g fk' -> unListT a (sk . g) fk') fk
diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs
index 14bc46b9b8..37acb25a1a 100644
--- a/compiler/utils/Maybes.hs
+++ b/compiler/utils/Maybes.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -95,9 +96,7 @@ tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler
-}
data MaybeErr err val = Succeeded val | Failed err
-
-instance Functor (MaybeErr err) where
- fmap = liftM
+ deriving (Functor)
instance Applicative (MaybeErr err) where
pure = Succeeded
diff --git a/compiler/utils/OrdList.hs b/compiler/utils/OrdList.hs
index 2d7a43f228..e8b50e5968 100644
--- a/compiler/utils/OrdList.hs
+++ b/compiler/utils/OrdList.hs
@@ -8,6 +8,7 @@ This is useful, general stuff for the Native Code Generator.
Provide trees (of instructions), so that lists of instructions
can be appended in linear time.
-}
+{-# LANGUAGE DeriveFunctor #-}
module OrdList (
OrdList,
@@ -34,6 +35,7 @@ data OrdList a
| Snoc (OrdList a) a
| Two (OrdList a) -- Invariant: non-empty
(OrdList a) -- Invariant: non-empty
+ deriving (Functor)
instance Outputable a => Outputable (OrdList a) where
ppr ol = ppr (fromOL ol) -- Convert to list and print that
@@ -46,9 +48,6 @@ instance Monoid (OrdList a) where
mappend = (Semigroup.<>)
mconcat = concatOL
-instance Functor OrdList where
- fmap = mapOL
-
instance Foldable OrdList where
foldr = foldrOL
@@ -117,12 +116,7 @@ fromOLReverse a = go a []
go (Many xs) acc = reverse xs ++ acc
mapOL :: (a -> b) -> OrdList a -> OrdList b
-mapOL _ None = None
-mapOL f (One x) = One (f x)
-mapOL f (Cons x xs) = Cons (f x) (mapOL f xs)
-mapOL f (Snoc xs x) = Snoc (mapOL f xs) (f x)
-mapOL f (Two x y) = Two (mapOL f x) (mapOL f y)
-mapOL f (Many xs) = Many (map f xs)
+mapOL = fmap
foldrOL :: (a->b->b) -> b -> OrdList a -> b
foldrOL _ z None = z
diff --git a/compiler/utils/Pair.hs b/compiler/utils/Pair.hs
index 036dab062d..e9313f89b2 100644
--- a/compiler/utils/Pair.hs
+++ b/compiler/utils/Pair.hs
@@ -4,6 +4,7 @@ Traversable instances.
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where
@@ -15,14 +16,13 @@ import Outputable
import qualified Data.Semigroup as Semi
data Pair a = Pair { pFst :: a, pSnd :: a }
+ deriving (Functor)
-- Note that Pair is a *unary* type constructor
-- whereas (,) is binary
-- The important thing about Pair is that it has a *homogeneous*
-- Functor instance, so you can easily apply the same function
-- to both components
-instance Functor Pair where
- fmap f (Pair x y) = Pair (f x) (f y)
instance Applicative Pair where
pure x = Pair x x
diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs
index 11bd7686d7..92269e91e7 100644
--- a/compiler/utils/State.hs
+++ b/compiler/utils/State.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE UnboxedTuples #-}
module State where
@@ -5,10 +6,7 @@ module State where
import GhcPrelude
newtype State s a = State { runState' :: s -> (# a, s #) }
-
-instance Functor (State s) where
- fmap f m = State $ \s -> case runState' m s of
- (# r, s' #) -> (# f r, s' #)
+ deriving (Functor)
instance Applicative (State s) where
pure x = State $ \s -> (# x, s #)
diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs
index bd530b76c3..60449bcc65 100644
--- a/compiler/utils/UniqDFM.hs
+++ b/compiler/utils/UniqDFM.hs
@@ -116,7 +116,7 @@ data TaggedVal val =
TaggedVal
val
{-# UNPACK #-} !Int -- ^ insertion time
- deriving Data
+ deriving (Data, Functor)
taggedFst :: TaggedVal val -> val
taggedFst (TaggedVal v _) = v
@@ -127,9 +127,6 @@ taggedSnd (TaggedVal _ i) = i
instance Eq val => Eq (TaggedVal val) where
(TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2
-instance Functor TaggedVal where
- fmap f (TaggedVal val i) = TaggedVal (f val) i
-
-- | Type of unique deterministic finite maps
data UniqDFM ele =
UDFM
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index 6ecb079ea0..4491d24a52 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, FlexibleInstances #-}
+{-# LANGUAGE CPP, FlexibleInstances, DeriveFunctor #-}
{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
@@ -255,6 +255,7 @@ recordBreak brkLoc = do
return (False, oldCounter)
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
+ deriving (Functor)
reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
@@ -262,9 +263,6 @@ reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
startGHCi :: GHCi a -> GHCiState -> Ghc a
startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
-instance Functor GHCi where
- fmap = liftM
-
instance Applicative GHCi where
pure a = GHCi $ \_ -> pure a
(<*>) = ap