From 4c44e323e8ac0e28e87e93ab53cbf7eb21ac9c25 Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski Date: Sat, 8 Jun 2019 20:48:07 +0200 Subject: Use DeriveFunctor throughout the codebase (#15654) --- compiler/basicTypes/UniqSupply.hs | 7 +++---- compiler/cmm/CmmLint.hs | 7 +++---- compiler/cmm/Hoopl/Block.hs | 12 ++++-------- compiler/cmm/PprC.hs | 9 +++------ compiler/codeGen/StgCmmExtCode.hs | 7 +++---- compiler/codeGen/StgCmmMonad.hs | 5 ++--- compiler/coreSyn/CoreLint.hs | 5 ++--- compiler/deSugar/Coverage.hs | 5 ++--- compiler/ghci/ByteCodeAsm.hs | 6 ++---- compiler/ghci/ByteCodeGen.hs | 6 ++---- compiler/hsSyn/Convert.hs | 7 +++---- compiler/hsSyn/HsBinds.hs | 9 ++------- compiler/llvmGen/LlvmCodeGen/Base.hs | 6 ++---- compiler/main/Annotations.hs | 6 ++---- compiler/main/CmdLineParser.hs | 5 ++--- compiler/main/GhcMonad.hs | 11 +++-------- compiler/main/HscTypes.hs | 5 ++--- compiler/main/PipelineMonad.hs | 5 ++--- compiler/main/TidyPgm.hs | 6 ++---- compiler/nativeGen/AsmCodeGen.hs | 9 ++++----- compiler/nativeGen/NCGMonad.hs | 7 +++---- compiler/nativeGen/RegAlloc/Linear/State.hs | 9 ++++----- compiler/prelude/PrelRules.hs | 7 +++---- compiler/rename/RnPat.hs | 7 +++---- compiler/simplCore/CoreMonad.hs | 5 ++--- compiler/simplCore/SimplMonad.hs | 7 +++---- compiler/specialise/Specialise.hs | 6 ++---- compiler/stgSyn/CoreToStg.hs | 8 +++----- compiler/stgSyn/StgLint.hs | 7 +++---- compiler/typecheck/TcCanonical.hs | 6 ++---- compiler/typecheck/TcFlatten.hs | 6 ++---- compiler/typecheck/TcRnTypes.hs | 9 +++------ compiler/typecheck/TcSMonad.hs | 7 ++----- compiler/typecheck/TcTyDecls.hs | 9 +++------ compiler/typecheck/TcUnify.hs | 7 +++---- compiler/types/FamInstEnv.hs | 6 +++--- compiler/types/Unify.hs | 4 +--- compiler/utils/Bag.hs | 11 +++-------- compiler/utils/IOEnv.hs | 6 ++---- compiler/utils/ListT.hs | 5 ++--- compiler/utils/Maybes.hs | 5 ++--- compiler/utils/OrdList.hs | 12 +++--------- compiler/utils/Pair.hs | 4 ++-- compiler/utils/State.hs | 6 ++---- compiler/utils/UniqDFM.hs | 5 +---- ghc/GHCi/UI/Monad.hs | 6 ++---- 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 822de431a4..2038801de3 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 @@ -1078,10 +1078,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 bbb29f5e38..941a6eab29 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} module TcCanonical( canonicalize, @@ -2198,10 +2199,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 8957014036..573051d657 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 @@ -3823,10 +3823,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 696303b949..f271ac5440 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 @@ -247,6 +247,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 @@ -254,9 +255,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 -- cgit v1.2.1