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 @@
-}
{-# 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
......
......@@ -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)
......
{-# 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
......
{-# 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)
......
{-# 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
......
{-# 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))
......
......@@ -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
......
......@@ -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
......
{-# 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
......
{-# 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
......
......@@ -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
......
......@@ -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
......
{-# 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)
......
......@@ -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
......
{-# 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)
......
{-# 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
......
......@@ -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)
......
{-# 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
......
......@@ -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)
......
......@@ -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
......
{-# 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
......
{-# 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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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