diff options
49 files changed, 173 insertions, 389 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index b718b73f30..4d5aebe052 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -153,10 +153,11 @@ import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Platform import GHC.Types.Unique.Set -import GHC.Utils.Misc import GHC.Core.Ppr ( {- instances -} ) import GHC.Types.SrcLoc +import qualified Data.Semigroup as S + -- ----------------------------------------------------------------------------- -- The CLabel type @@ -343,26 +344,26 @@ newtype NeedExternDecl -- code-generation. See Note [Unique Determinism and code generation] instance Ord CLabel where compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` + compare a1 a2 S.<> + compare b1 b2 S.<> compare c1 c2 compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` + compare a1 a2 S.<> + compare b1 b2 S.<> -- This non-determinism is "safe" in the sense that it only affects object code, -- which is currently not covered by GHC's determinism guarantees. See #12935. - uniqCompareFS c1 c2 `thenCmp` + uniqCompareFS c1 c2 S.<> compare d1 d2 compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2 compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2 compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) = - uniqCompareFS a1 a2 `thenCmp` - compare b1 b2 `thenCmp` - compare c1 c2 `thenCmp` + uniqCompareFS a1 a2 S.<> + compare b1 b2 S.<> + compare c1 c2 S.<> compare d1 d2 compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2 compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) = - compare a1 a2 `thenCmp` + compare a1 a2 S.<> lexicalCompareFS b1 b2 compare (StringLitLabel u1) (StringLitLabel u2) = nonDetCmpUnique u1 u2 @@ -373,10 +374,10 @@ instance Ord CLabel where compare (IPE_Label a1) (IPE_Label a2) = compare a1 a2 compare (ModuleLabel m1 k1) (ModuleLabel m2 k2) = - compare m1 m2 `thenCmp` + compare m1 m2 S.<> compare k1 k2 compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) = - compare a1 a2 `thenCmp` + compare a1 a2 S.<> compare b1 b2 compare PicBaseLabel PicBaseLabel = EQ compare (DeadStripPreventer a1) (DeadStripPreventer a2) = diff --git a/compiler/GHC/Cmm/CommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs index 90e3a7abb1..ed6240e780 100644 --- a/compiler/GHC/Cmm/CommonBlockElim.hs +++ b/compiler/GHC/Cmm/CommonBlockElim.hs @@ -18,6 +18,7 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Collections +import Data.Functor.Classes (liftEq) import Data.Maybe (mapMaybe) import qualified Data.List as List import Data.Word @@ -213,7 +214,7 @@ eqMiddleWith eqBid (CmmStore l1 r1 _) (CmmStore l2 r2 _) = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1) (CmmUnsafeForeignCall t2 r2 a2) - = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2 + = t1 == t2 && r1 == r2 && liftEq (eqExprWith eqBid) a1 a2 eqMiddleWith _ _ _ = False eqExprWith :: (BlockId -> BlockId -> Bool) @@ -224,12 +225,10 @@ eqExprWith eqBid = eq CmmLoad e1 t1 a1 `eq` CmmLoad e2 t2 a2 = t1 `cmmEqType` t2 && e1 `eq` e2 && a1==a2 CmmReg r1 `eq` CmmReg r2 = r1==r2 CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2 - CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2 + CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && liftEq eq es1 es2 CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2 _e1 `eq` _e2 = False - xs `eqs` ys = eqListWith eq xs ys - eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2 eqLit l1 l2 = l1 == l2 @@ -251,7 +250,7 @@ eqBlockBodyWith eqBid block block' (_,m',l') = blockSplit block' nodes' = filter (not . dont_care) (blockToList m') - equal = eqListWith (eqMiddleWith eqBid) nodes nodes' && + equal = liftEq (eqMiddleWith eqBid) nodes nodes' && eqLastWith eqBid l l' @@ -260,21 +259,11 @@ eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2 eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) = c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2 eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) = - t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2 + t1 == t2 && liftEq eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2 eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) = e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2 eqLastWith _ _ _ = False -eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool -eqMaybeWith eltEq (Just e) (Just e') = eltEq e e' -eqMaybeWith _ Nothing Nothing = True -eqMaybeWith _ _ _ = False - -eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool -eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs -eqListWith _ [] [] = True -eqListWith _ _ _ = False - -- | Given a block map, ensure that all "target" blocks are covered by -- the same ticks as the respective "source" blocks. This not only -- means copying ticks, but also adjusting tick scopes where diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs index 03d667b4d4..8b4b1cefb0 100644 --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -6,6 +6,7 @@ -- ----------------------------------------------------------------------------- {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} module GHC.Cmm.Lint ( @@ -26,7 +27,10 @@ import GHC.Cmm.Switch (switchTargetsToList) import GHC.Cmm.CLabel (pprDebugCLabel) import GHC.Utils.Outputable -import Control.Monad (ap, unless) +import Control.Monad (unless) +import Control.Monad.Trans.Except (ExceptT (..), Except) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Data.Functor.Identity (Identity (..)) -- Things to check: -- - invariant on CmmBlock in GHC.Cmm.Expr (see comment there) @@ -261,17 +265,8 @@ checkCond platform expr -- just a basic error monad: newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a } - deriving (Functor) - -instance Applicative CmmLint where - pure a = CmmLint (\_ -> Right a) - (<*>) = ap - -instance Monad CmmLint where - CmmLint m >>= k = CmmLint $ \platform -> - case m platform of - Left e -> Left e - Right a -> unCL (k a) platform + deriving stock (Functor) + deriving (Applicative, Monad) via ReaderT Platform (Except SDoc) getPlatform :: CmmLint Platform getPlatform = CmmLint $ \platform -> Right platform diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index 24983360c2..d8b1e43aa0 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -45,11 +45,11 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label +import Data.Functor.Classes (liftCompare) import Data.Maybe import Data.List (tails,sortBy) import GHC.Types.Unique (nonDetCmpUnique) import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Misc ------------------------ @@ -912,7 +912,7 @@ instance Ord CmmTickScope where compare GlobalScope _ = LT compare _ GlobalScope = GT compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u' - compare scope scope' = cmpList nonDetCmpUnique + compare scope scope' = liftCompare nonDetCmpUnique (sortBy nonDetCmpUnique $ scopeUniques scope) (sortBy nonDetCmpUnique $ scopeUniques scope') diff --git a/compiler/GHC/CmmToAsm/CFG/Dominators.hs b/compiler/GHC/CmmToAsm/CFG/Dominators.hs index 428603d09c..a24e9528f3 100644 --- a/compiler/GHC/CmmToAsm/CFG/Dominators.hs +++ b/compiler/GHC/CmmToAsm/CFG/Dominators.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Strict #-} @@ -528,8 +529,7 @@ renum from = (\(_,m,g)->(g,m)) -- Nothing better than reinventing the state monad. newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o} -instance Functor (S z s) where - fmap f (S g) = S (\k -> g (k . f)) + deriving (Functor) instance Monad (S z s) where return = pure S g >>= f = S (\k -> g (\a -> unS (f a) k)) diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs index a1c6e6485c..eb445649c3 100644 --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} -- ----------------------------------------------------------------------------- -- @@ -20,7 +22,6 @@ module GHC.CmmToAsm.Monad ( addImmediateSuccessorNat, updateCfgNat, getUniqueNat, - mapAccumLNat, setDeltaNat, getConfig, getPlatform, @@ -66,10 +67,9 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique ( Unique ) import GHC.Unit.Module -import Control.Monad ( ap ) - import GHC.Utils.Outputable (SDoc, ppr) import GHC.Utils.Panic (pprPanic) +import GHC.Utils.Monad.State.Strict (State (..), runState, state) import GHC.Utils.Misc import GHC.CmmToAsm.CFG import GHC.CmmToAsm.CFG.Weight @@ -120,8 +120,14 @@ data NatM_State type DwarfFiles = UniqFM FastString (FastString, Int) -newtype NatM result = NatM (NatM_State -> (result, NatM_State)) - deriving (Functor) +newtype NatM a = NatM' (State NatM_State a) + deriving stock (Functor) + deriving (Applicative, Monad) via State NatM_State + +pattern NatM :: (NatM_State -> (a, NatM_State)) -> NatM a +pattern NatM f <- NatM' (runState -> f) + where NatM f = NatM' (state f) +{-# COMPLETE NatM #-} unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a @@ -142,15 +148,7 @@ mkNatM_State us delta config } initNat :: NatM_State -> NatM a -> (a, NatM_State) -initNat init_st m - = case unNat m init_st of { (r,st) -> (r,st) } - -instance Applicative NatM where - pure = returnNat - (<*>) = ap - -instance Monad NatM where - (>>=) = thenNat +initNat = flip unNat instance MonadUnique NatM where getUniqueSupplyM = NatM $ \st -> @@ -161,27 +159,6 @@ instance MonadUnique NatM where case takeUniqFromSupply (natm_us st) of (uniq, us') -> (uniq, st {natm_us = us'}) -thenNat :: NatM a -> (a -> NatM b) -> NatM b -thenNat expr cont - = NatM $ \st -> case unNat expr st of - (result, st') -> unNat (cont result) st' - -returnNat :: a -> NatM a -returnNat result - = NatM $ \st -> (result, st) - -mapAccumLNat :: (acc -> x -> NatM (acc, y)) - -> acc - -> [x] - -> NatM (acc, [y]) - -mapAccumLNat _ b [] - = return (b, []) -mapAccumLNat f b (x:xs) - = do (b__2, x__2) <- f b x - (b__3, xs__2) <- mapAccumLNat f b__2 xs - return (b__3, x__2:xs__2) - getUniqueNat :: NatM Unique getUniqueNat = NatM $ \ st -> case takeUniqFromSupply $ natm_us st of @@ -241,9 +218,7 @@ addImmediateSuccessorNat block succ = do getBlockIdNat :: NatM BlockId getBlockIdNat - = do u <- getUniqueNat - return (mkBlockId u) - + = mkBlockId <$> getUniqueNat getNewLabelNat :: NatM CLabel getNewLabelNat diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index c55029175c..3608ac7033 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- @@ -48,6 +51,7 @@ import GHC.Types.Unique import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Monad.State.Strict (State (..), runState, state) import GHC.Utils.Misc import GHC.Utils.Trace @@ -57,7 +61,6 @@ import Data.Char import Data.List (intersperse) import Data.Map (Map) import qualified Data.Map as Map -import Control.Monad (ap) import GHC.Float -- -------------------------------------------------------------------------- @@ -1234,14 +1237,14 @@ pprExternDecl platform lbl <> semi type TEState = (UniqSet LocalReg, Map CLabel ()) -newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor) - -instance Applicative TE where - pure a = TE $ \s -> (a, s) - (<*>) = ap - -instance Monad TE where - TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s' +newtype TE a = TE' (State TEState a) + deriving stock (Functor) + deriving (Applicative, Monad) via State TEState + +pattern TE :: (TEState -> (a, TEState)) -> TE a +pattern TE f <- TE' (runState -> f) + where TE f = TE' (state f) +{-# COMPLETE TE #-} te_lbl :: CLabel -> TE () te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls)) diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index 4e3c95771e..18296158e3 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -57,7 +58,7 @@ import GHC.Types.Unique.Supply import GHC.Utils.Logger import Data.Maybe (fromJust) -import Control.Monad (ap) +import Control.Monad.Trans.State (StateT (..)) import Data.List (sortBy, groupBy, isPrefixOf) import Data.Ord (comparing) @@ -275,15 +276,8 @@ type LlvmEnvMap = UniqFM Unique LlvmType -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } - deriving (Functor) - -instance Applicative LlvmM where - pure x = LlvmM $ \env -> return (x, env) - (<*>) = ap - -instance Monad LlvmM where - m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env - runLlvmM (f x) env' + deriving stock (Functor) + deriving (Applicative, Monad) via StateT LlvmEnv IO instance HasLogger LlvmM where getLogger = LlvmM $ \env -> return (envLogger env, env) diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 917022c78d..cab154aa5c 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -51,8 +52,7 @@ module GHC.Core.Coercion ( -- ** Decomposition instNewTyCon_maybe, - NormaliseStepper, NormaliseStepResult(..), composeSteppers, - mapStepResult, unwrapNewTypeStepper, + NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper, topNormaliseNewType_maybe, topNormaliseTypeX, decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, @@ -1712,18 +1712,13 @@ data NormaliseStepResult ev | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; -- ^ ev is evidence; -- Usually a co :: old type ~ new type + deriving (Functor) instance Outputable ev => Outputable (NormaliseStepResult ev) where ppr NS_Done = text "NS_Done" ppr NS_Abort = text "NS_Abort" ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev] -mapStepResult :: (ev1 -> ev2) - -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 -mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) -mapStepResult _ NS_Done = NS_Done -mapStepResult _ NS_Abort = NS_Abort - -- | Try one stepper and then try the next, if the first doesn't make -- progress. -- So if it returns NS_Done, it means that both steppers are satisfied diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 60e2c90a2a..d59376622f 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -1315,7 +1315,7 @@ topNormaliseType_maybe env ty unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) unwrapNewTypeStepper' rec_nts tc tys - = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys + = (, MRefl) <$> unwrapNewTypeStepper rec_nts tc tys -- second coercion below is the kind coercion relating the original type's kind -- to the normalised type's kind diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index e51fe7e88c..17519d8dd5 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -296,6 +296,7 @@ import GHC.Types.Unique ( nonDetCmpUnique ) import GHC.Data.Maybe ( orElse, expectJust, isJust ) import Control.Monad ( guard ) +import qualified Data.Semigroup as S -- import GHC.Utils.Trace -- $type_classification @@ -2882,7 +2883,7 @@ nonDetCmpTypeX env orig_t1 orig_t2 = go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) -- NB: nonDepCmpTypeX does the kind check requested by -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep - = liftOrdering (nonDetCmpTypeX env s1 s2 `thenCmp` nonDetCmpTypeX env t1 t2) + = liftOrdering (nonDetCmpTypeX env s1 s2 S.<> nonDetCmpTypeX env t1 t2) `thenCmpTy` go env w1 w2 -- Comparing multiplicities last because the test is usually true go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) @@ -2916,8 +2917,7 @@ nonDetCmpTypeX env orig_t1 orig_t2 = ------------- nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering nonDetCmpTypesX _ [] [] = EQ -nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 - `thenCmp` +nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 S.<> nonDetCmpTypesX env tys1 tys2 nonDetCmpTypesX _ [] _ = LT nonDetCmpTypesX _ _ [] = GT diff --git a/compiler/GHC/Data/Bag.hs b/compiler/GHC/Data/Bag.hs index 0dcdef55a5..91b079f419 100644 --- a/compiler/GHC/Data/Bag.hs +++ b/compiler/GHC/Data/Bag.hs @@ -6,7 +6,7 @@ Bag: an unordered collection with duplicates -} -{-# LANGUAGE ScopedTypeVariables, DeriveFunctor, TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables, DeriveTraversable, TypeFamilies #-} module GHC.Data.Bag ( Bag, -- abstract type @@ -36,7 +36,6 @@ import Data.Data import Data.Maybe( mapMaybe, listToMaybe ) import Data.List ( partition, mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.Foldable as Foldable import qualified Data.Semigroup ( (<>) ) infixr 3 `consBag` @@ -47,7 +46,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) + deriving (Foldable, Functor, Traversable) emptyBag :: Bag a emptyBag = EmptyBag @@ -324,28 +323,6 @@ instance Data a => Data (Bag a) where dataTypeOf _ = mkNoRepType "Bag" dataCast1 x = gcast1 x -instance Foldable.Foldable Bag where - foldr _ z EmptyBag = z - foldr k z (UnitBag x) = k x z - foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1 - foldr k z (ListBag xs) = foldr k z xs - - foldl _ z EmptyBag = z - foldl k z (UnitBag x) = k z x - foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2 - foldl k z (ListBag xs) = foldl k z xs - - foldl' _ z EmptyBag = z - foldl' k z (UnitBag x) = k z x - foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2 - foldl' k z (ListBag xs) = foldl' k z xs - -instance Traversable Bag where - traverse _ EmptyBag = pure EmptyBag - traverse f (UnitBag x) = UnitBag <$> f x - traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2 - traverse f (ListBag xs) = ListBag <$> traverse f xs - instance IsList (Bag a) where type Item (Bag a) = a fromList = listToBag diff --git a/compiler/GHC/Data/Maybe.hs b/compiler/GHC/Data/Maybe.hs index 215a2a0d6f..6e68ef7d0a 100644 --- a/compiler/GHC/Data/Maybe.hs +++ b/compiler/GHC/Data/Maybe.hs @@ -32,7 +32,7 @@ import Control.Monad import Control.Monad.Trans.Maybe import Control.Exception (SomeException(..)) import Data.Maybe -import Data.Foldable ( foldlM ) +import Data.Foldable ( foldlM, for_ ) import GHC.Utils.Misc (HasCallStack) import Data.List.NonEmpty ( NonEmpty ) @@ -71,8 +71,7 @@ expectJust _ (Just x) = x expectJust err Nothing = error ("expectJust " ++ err) whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenIsJust (Just x) f = f x -whenIsJust Nothing _ = return () +whenIsJust = for_ -- | Flipped version of @fromMaybe@, useful for chaining. orElse :: Maybe a -> a -> a diff --git a/compiler/GHC/Data/Pair.hs b/compiler/GHC/Data/Pair.hs index 52c0fc211f..fc420e0e8d 100644 --- a/compiler/GHC/Data/Pair.hs +++ b/compiler/GHC/Data/Pair.hs @@ -4,7 +4,7 @@ Traversable instances. -} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} module GHC.Data.Pair ( Pair(..) @@ -22,7 +22,7 @@ import GHC.Utils.Outputable import qualified Data.Semigroup as Semi data Pair a = Pair { pFst :: a, pSnd :: a } - deriving (Functor) + deriving (Foldable, Functor, Traversable) -- Note that Pair is a *unary* type constructor -- whereas (,) is binary @@ -34,12 +34,6 @@ instance Applicative Pair where pure x = Pair x x (Pair f g) <*> (Pair x y) = Pair (f x) (g y) -instance Foldable Pair where - foldMap f (Pair x y) = f x `mappend` f y - -instance Traversable Pair where - traverse f (Pair x y) = Pair <$> f x <*> f y - instance Semi.Semigroup a => Semi.Semigroup (Pair a) where Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) diff --git a/compiler/GHC/Data/Stream.hs b/compiler/GHC/Data/Stream.hs index 32d5ff7e62..d41b64b226 100644 --- a/compiler/GHC/Data/Stream.hs +++ b/compiler/GHC/Data/Stream.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} -- ----------------------------------------------------------------------------- @@ -66,9 +67,7 @@ runStream st = runStreamInternal st pure Done data StreamS m a b = Yield a (StreamS m a b) | Done b | Effect (m (StreamS m a b)) - -instance Monad m => Functor (StreamS m a) where - fmap = liftM + deriving (Functor) instance Monad m => Applicative (StreamS m a) where pure = Done diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs index 0c4ed95618..e7d734bb42 100644 --- a/compiler/GHC/Driver/CmdLine.hs +++ b/compiler/GHC/Driver/CmdLine.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------- @@ -38,7 +39,7 @@ import Data.List (sortBy, intercalate, stripPrefix) import GHC.ResponseFile import Control.Exception (IOException, catch) -import Control.Monad (liftM, ap) +import Control.Monad (ap) import Control.Monad.IO.Class -------------------------------------------------------- @@ -138,9 +139,7 @@ type Warns = Bag Warn newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg -> Errs -> Warns -> m (Errs, Warns, a) } - -instance Monad m => Functor (EwM m) where - fmap = liftM + deriving (Functor) instance Monad m => Applicative (EwM m) where pure v = EwM (\_ e w -> return (e, w, v)) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 09e6be023a..9089a2baa9 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE FlexibleContexts #-} @@ -967,8 +968,7 @@ these modules together. -- | Simple wrapper around MVar which allows a functor instance. data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a)) -instance Functor ResultVar where - fmap f (ResultVar g var) = ResultVar (f . g) var +deriving instance Functor ResultVar mkResultVar :: MVar (Maybe a) -> ResultVar a mkResultVar = ResultVar id diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index bfe7e0feb8..3c2fbbac34 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -154,8 +154,8 @@ logDiagnostics warns = do -- e.g., to maintain additional state consider wrapping this monad or using -- 'GhcT'. newtype Ghc a = Ghc { unGhc :: Session -> IO a } - deriving (Functor) - deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session IO) + deriving stock (Functor) + deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session IO) -- | The Session is a handle to the complete state of a compilation -- session. A compilation session consists of a set of modules @@ -163,19 +163,6 @@ newtype Ghc a = Ghc { unGhc :: Session -> IO a } -- interactive evaluation, and various caches. data Session = Session !(IORef HscEnv) -instance Applicative Ghc where - pure a = Ghc $ \_ -> return a - g <*> m = do f <- g; a <- m; return (f a) - -instance Monad Ghc where - m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s - -instance MonadIO Ghc where - liftIO ioA = Ghc $ \_ -> ioA - -instance MonadFix Ghc where - mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) - instance HasDynFlags Ghc where getDynFlags = getSessionDynFlags @@ -213,22 +200,12 @@ 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) - deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session m) + deriving stock (Functor) + deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session m) liftGhcT :: m a -> GhcT m a liftGhcT m = GhcT $ \_ -> m -instance Applicative m => Applicative (GhcT m) where - pure x = GhcT $ \_ -> pure x - g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s - -instance Monad m => Monad (GhcT m) where - m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s - -instance MonadIO m => MonadIO (GhcT m) where - liftIO ioA = GhcT $ \_ -> liftIO ioA - instance MonadIO m => HasDynFlags (GhcT m) where getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index db25fc7bc7..38bb6598b4 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} @@ -1842,6 +1843,7 @@ parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a) + deriving (Functor) instance Monad (CmdLineP s) where CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g) @@ -1851,9 +1853,6 @@ instance Applicative (CmdLineP s) where pure x = CmdLineP (pure x) (<*>) = ap -instance Functor (CmdLineP s) where - fmap f (CmdLineP k) = CmdLineP (fmap f k) - getCmdLineState :: CmdLineP s s getCmdLineState = CmdLineP State.get diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 1095402c73..983f3086b5 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -359,8 +359,7 @@ deSugarExpr hsc_env tc_expr = do addExportFlagsAndRules :: Backend -> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)] -addExportFlagsAndRules bcknd exports keep_alive rules prs - = mapFst add_one prs +addExportFlagsAndRules bcknd exports keep_alive rules = mapFst add_one where add_one bndr = add_rules name (add_export name bndr) where diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index 7bf49a6c8d..f8436fecd8 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -534,7 +534,7 @@ filterDecls = filter (isHandled . unXRec @p . fst) -- | Go through all class declarations and filter their sub-declarations filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)] -filterClasses = map (first (mapLoc filterClass)) +filterClasses = map (first (fmap filterClass)) where filterClass (TyClD x c@(ClassDecl {})) = TyClD x $ c { tcdSigs = @@ -554,7 +554,7 @@ mkDecls :: (struct -> [GenLocated l decl]) -> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl] -mkDecls field con = map (mapLoc con) . field +mkDecls field con = map (fmap con) . field -- | Extracts out individual maps of documentation added via Template Haskell's -- @putDoc@. diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs index f47ee5689e..43a12e5ed8 100644 --- a/compiler/GHC/HsToCore/Ticks.hs +++ b/compiler/GHC/HsToCore/Ticks.hs @@ -35,7 +35,6 @@ import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Monad import GHC.Utils.Logger import GHC.Types.SrcLoc import GHC.Types.Basic @@ -528,7 +527,7 @@ addTickHsExpr (HsIf x e1 e2 e3) = (addTickLHsExprOptAlt True e3) addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True - ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts + ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } addTickHsExpr (HsLet x tkLet binds tkIn e) = bindLocals (collectLocalBinders CollNoDictBinders binds) $ do @@ -586,7 +585,7 @@ addTickHsExpr e@(HsProjection {}) = return e addTickHsExpr (HsProc x pat cmdtop) = liftM2 (HsProc x) (addTickLPat pat) - (liftL (addTickHsCmdTop) cmdtop) + (traverse (addTickHsCmdTop) cmdtop) addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) = liftM (XExpr . WrapExpr . HsWrap w) $ (addTickHsExpr e) -- Explicitly no tick on inside @@ -615,7 +614,7 @@ addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do let isOneOfMany = matchesOneOfMany matches - matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches + matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam)) matches return $ mg { mg_alts = L l matches' } addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) @@ -631,7 +630,7 @@ addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) = bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded + guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda)) guarded return $ GRHSs x guarded' local_binds' where binders = collectLocalBinders CollNoDictBinders local_binds @@ -665,7 +664,7 @@ addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a) addTickLStmts' isGuard lstmts res = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $ - do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts + do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts ; a <- res ; return (lstmts', a) } @@ -709,7 +708,7 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts , trS_ret = returnExpr, trS_bind = bindExpr , trS_fmap = liftMExpr }) = do t_s <- addTickLStmts isGuard stmts - t_y <- fmapMaybeM addTickLHsExprRHS by + t_y <- traverse addTickLHsExprRHS by t_u <- addTickLHsExprRHS using t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr @@ -782,7 +781,7 @@ addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) addTickHsIPBinds (IPBinds dictbinds ipbinds) = liftM2 IPBinds (return dictbinds) - (mapM (liftL (addTickIPBind)) ipbinds) + (mapM (traverse (addTickIPBind)) ipbinds) addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) addTickIPBind (IPBind x nm e) = @@ -859,7 +858,7 @@ addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = (addTickLHsExpr e) (return f) (return fix) - (mapM (liftL (addTickHsCmdTop)) cmdtop) + (mapM (traverse (addTickHsCmdTop)) cmdtop) addTickHsCmd (XCmd (HsWrap w cmd)) = liftM XCmd $ @@ -871,7 +870,7 @@ addTickHsCmd (XCmd (HsWrap w cmd)) = addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do - matches' <- mapM (liftL addTickCmdMatch) matches + matches' <- mapM (traverse addTickCmdMatch) matches return $ mg { mg_alts = L l matches' } addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) @@ -884,7 +883,7 @@ addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) addTickCmdGRHSs (GRHSs x guarded local_binds) = bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (liftL addTickCmdGRHS) guarded + guarded' <- mapM (traverse addTickCmdGRHS) guarded return $ GRHSs x guarded' local_binds' where binders = collectLocalBinders CollNoDictBinders local_binds @@ -907,7 +906,7 @@ addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) addTickLCmdStmts' lstmts res = bindLocals binders $ do - lstmts' <- mapM (liftL addTickCmdStmt) lstmts + lstmts' <- mapM (traverse addTickCmdStmt) lstmts a <- res return (lstmts', a) where diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 64eac53af0..de66cdaef2 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -944,7 +944,7 @@ instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where name' :: LocatedN Name name' = case hiePass @p of HieRn -> name - HieTc -> mapLoc varName name + HieTc -> fmap varName name toHie (StmtCtxt a) = toHie a toHie _ = pure [] diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs index 674741bfd0..08412349d2 100644 --- a/compiler/GHC/Iface/Ext/Types.hs +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -28,7 +28,6 @@ import GHC.Types.SrcLoc import GHC.Types.Avail import GHC.Types.Unique import qualified GHC.Utils.Outputable as O ( (<>) ) -import GHC.Utils.Misc import GHC.Utils.Panic import qualified Data.Array as A @@ -41,6 +40,7 @@ import Data.Word ( Word8 ) import Control.Applicative ( (<|>) ) import Data.Coerce ( coerce ) import Data.Function ( on ) +import qualified Data.Semigroup as S type Span = RealSrcSpan @@ -751,9 +751,9 @@ data HieName deriving (Eq) instance Ord HieName where - compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` leftmost_smallest c f + compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) S.<> leftmost_smallest c f -- TODO (int-index): Perhaps use RealSrcSpan in HieName? - compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` leftmost_smallest b d + compare (LocalName a b) (LocalName c d) = compare a c S.<> leftmost_smallest b d -- TODO (int-index): Perhaps use RealSrcSpan in HieName? compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b -- Not actually non deterministic as it is a KnownKey diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 5db10d502b..fde785284a 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -77,7 +77,7 @@ import GHC.Types.CompleteMatch import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Misc hiding ( eqListBy ) +import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Utils.Trace diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 64fff6cdc1..f4fac35375 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -44,7 +44,7 @@ import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable -import GHC.Utils.Misc as Utils hiding ( eqListBy ) +import GHC.Utils.Misc as Utils import GHC.Utils.Binary import GHC.Utils.Fingerprint import GHC.Utils.Exception diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index bdf1547f23..a7c3162930 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -871,7 +871,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = name , ifFieldLabels = field_labels }) = do { traceIf (text "tc_iface_decl" <+> ppr name) ; matcher <- tc_pr if_matcher - ; builder <- fmapMaybeM tc_pr if_builder + ; builder <- traverse tc_pr if_builder ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do { patsyn <- forkM (mk_doc name) $ diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 360c464327..4b367b2da9 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2427,7 +2427,7 @@ forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) } | {- empty -} { noLoc ([], Nothing) } constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) } - : infixtype {% fmap (reLoc. (mapLoc (\b -> (dataConBuilderCon b, + : infixtype {% fmap (reLoc. (fmap (\b -> (dataConBuilderCon b, dataConBuilderDetails b)))) (runPV $1) } @@ -2935,7 +2935,7 @@ aexp2 :: { ECP } -- Template Haskell Extension | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 } - | splice_typed { ecpFromExp $ mapLoc (uncurry HsTypedSplice) (reLocA $1) } + | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA $1) } | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) } | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) } @@ -2973,8 +2973,8 @@ projection | PREFIX_PROJ field {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $1 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) } splice_exp :: { LHsExpr GhcPs } - : splice_untyped { mapLoc (HsUntypedSplice noAnn) (reLocA $1) } - | splice_typed { mapLoc (uncurry HsTypedSplice) (reLocA $1) } + : splice_untyped { fmap (HsUntypedSplice noAnn) (reLocA $1) } + | splice_typed { fmap (uncurry HsTypedSplice) (reLocA $1) } splice_untyped :: { Located (HsUntypedSplice GhcPs) } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index d89ef3ee8d..19dac05130 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -1786,7 +1787,7 @@ instance DisambECP (HsExpr GhcPs) where return $ L (noAnnSrcSpan l) (ExplicitList (EpAnn (spanAsAnchor l) anns cs) xs) mkHsSplicePV sp@(L l _) = do cs <- getCommentsFor l - return $ mapLoc (HsUntypedSplice (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp + return $ fmap (HsUntypedSplice (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do cs <- getCommentsFor l r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (EpAnn (spanAsAnchor l) anns cs) @@ -2811,7 +2812,7 @@ mkModuleImpExp anns (L l specname) subs = do ieNameFromSpec (ImpExpQcType r (L l n)) = IEType r (L l n) ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" - wrapped = map (mapLoc ieNameFromSpec) + wrapped = map (fmap ieNameFromSpec) mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space -> P (LocatedN RdrName) @@ -2887,6 +2888,7 @@ data PV_Accum = } data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum + deriving (Foldable, Functor, Traversable) -- During parsing, we make use of several monadic effects: reporting parse errors, -- accumulating warnings, adding API annotations, and checking for extensions. These @@ -2908,9 +2910,7 @@ data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum -- abParser :: forall x. DisambAB x => P (PV x) -- newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } - -instance Functor PV where - fmap = liftM + deriving (Functor) instance Applicative PV where pure a = a `seq` PV (\_ acc -> PV_Ok acc a) diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 00fa69b770..8b57a72d52 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -1308,7 +1308,7 @@ reportExtraDocs = ********************************************************************* -} mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) -mkDocHsDecl layout_info a = mapLoc (DocD noExtField) <$> mkDocDecl layout_info a +mkDocHsDecl layout_info a = fmap (DocD noExtField) <$> mkDocDecl layout_info a mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) mkDocDecl layout_info (L l_comment hdk_comment) @@ -1530,7 +1530,7 @@ mcons = maybe id (:) -- Map a function over a list of located items. mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b] -mapLL f = map (mapLoc f) +mapLL f = map (fmap f) {- Note [Old solution: Haddock in the grammar] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index 5639d2a6c6..b843ff6d5a 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -57,6 +57,7 @@ import GHC.Utils.Outputable (empty) import Data.List (sortBy, partition, nub) import Data.List.NonEmpty ( pattern (:|), NonEmpty ) import Data.Function ( on ) +import qualified Data.Semigroup as S {- ************************************************************************ @@ -303,10 +304,7 @@ importSuggestions looking_for global_env hpt currMod imports rdr_name pick = listToMaybe . sortBy cmp . filter select where select imv = case mod_name of Just name -> imv_name imv == name Nothing -> not (imv_qualified imv) - cmp a b = - (compare `on` imv_is_hiding) a b - `thenCmp` - (SrcLoc.leftmost_smallest `on` imv_span) a b + cmp = on compare imv_is_hiding S.<> on SrcLoc.leftmost_smallest imv_span -- Which of these would export a 'foo' -- (all of these are restricted imports, because if they were not, we diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index c17fee9753..4966a65b1f 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -53,6 +53,8 @@ import GHC.Types.Var.Set import Control.Monad import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ask) +import Data.Function (on) +import Data.Functor.Classes (liftEq) import Data.List (sortBy) import Data.Maybe @@ -685,7 +687,7 @@ simplifyInstanceContexts infer_specs else iterate_deriv (n+1) new_solns } - eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b) + eqSolution = (liftEq . liftEq) eqType `on` canSolution -- Canonicalise for comparison -- See Note [Deterministic simplifyInstanceContexts] canSolution = map (sortBy nonDetCmpType) diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 1011144afc..5254fc4616 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -462,7 +462,7 @@ addHoleFitDocs fits = ; if showDocs then do { dflags <- getDynFlags ; mb_local_docs <- extractDocs dflags =<< getGblEnv - ; (mods_without_docs, fits') <- mapAccumM (upd mb_local_docs) Set.empty fits + ; (mods_without_docs, fits') <- mapAccumLM (upd mb_local_docs) Set.empty fits ; report mods_without_docs ; return fits' } else return fits } diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index fedea75796..10e665051d 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -271,7 +271,7 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcCheckMonoExpr expr ty - ; let d = mapLoc (toDict ipClass p ty) expr' + ; let d = fmap (toDict ipClass p ty) expr' ; return (ip_id, (IPBind ip_id l_name d)) } -- Coerces a `t` into a dictionary for `IP "x" t`. diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index c6deae4be2..b649891d04 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -1058,7 +1058,7 @@ tc_infer_hs_type _ (XHsType ty) | ATyVar nm tv <- nonDetNameEnvElts (tcl_env env) ] subst = mkTvSubst (mkInScopeSetList $ map snd subst_prs) - (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs) + (listToUFM_Directly $ map (fmap mkTyVarTy) subst_prs) ty' = substTy subst ty return (ty', tcTypeKind ty') @@ -3226,14 +3226,14 @@ bindExplicitTKBndrs_Q_Tv -> TcM ([TcTyVar], a) -- These do not clone: see Note [Cloning for type variable binders] bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside - = liftFstM binderVars $ + = mapFst binderVars $ bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True , sm_kind = ctxt_kind, sm_tvtv = SMDSkolemTv skol_info }) hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside - = liftFstM binderVars $ + = mapFst binderVars $ bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True , sm_tvtv = SMDTyVarTv, sm_kind = ctxt_kind }) hs_bndrs thing_inside diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 4a575d614e..8c81e860c5 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -558,8 +558,7 @@ tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty -- which would lead to terrible error messages unwrap_newtype_instance rec_nts tc tys | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys - = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $ - unwrap_newtype rec_nts tc' tys' + = fmap (mkTransCo co) <$> unwrap_newtype rec_nts tc' tys' | otherwise = NS_Done unwrap_newtype rec_nts tc tys @@ -567,8 +566,7 @@ tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty , Just gre <- lookupGRE_Name rdr_env (dataConName con) -- This is where we check that the -- data constructor is in scope - = mapStepResult (\co -> (unitBag gre, co)) $ - unwrapNewTypeStepper rec_nts tc tys + = (,) (unitBag gre) <$> unwrapNewTypeStepper rec_nts tc tys | otherwise = NS_Done diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index abc4031df0..f79beaaad0 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -176,6 +176,7 @@ import GHC.Data.List.SetOps import GHC.Data.Bag import qualified GHC.Data.BooleanFormula as BF +import Data.Functor.Classes ( liftEq ) import Data.List ( sortBy, sort ) import Data.Ord import Data.Data ( Data ) @@ -1065,7 +1066,7 @@ checkBootTyCon is_boot tc1 tc2 (text "The types of" <+> pname1 <+> text "are different") `andThenCheck` if is_boot - then check (eqMaybeBy eqDM def_meth1 def_meth2) + then check (liftEq eqDM def_meth1 def_meth2) (text "The default methods associated with" <+> pname1 <+> text "are different") else check (subDM op_ty1 def_meth1 def_meth2) @@ -1114,15 +1115,15 @@ checkBootTyCon is_boot tc1 tc2 eqATDef _ _ = False eqFD (as1,bs1) (as2,bs2) = - eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + liftEq (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + liftEq (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) in checkRoles roles1 roles2 `andThenCheck` -- Checks kind of class - check (eqListBy eqFD clas_fds1 clas_fds2) + check (liftEq eqFD clas_fds1 clas_fds2) (text "The functional dependencies do not match") `andThenCheck` checkUnless (isAbstractTyCon tc1) $ - check (eqListBy (eqTypeX env) sc_theta1 sc_theta2) + check (liftEq (eqTypeX env) sc_theta1 sc_theta2) (text "The class constraints do not match") `andThenCheck` checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck` @@ -1190,7 +1191,7 @@ checkBootTyCon is_boot tc1 tc2 , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = assert (tc1 == tc2) $ checkRoles roles1 roles2 `andThenCheck` - check (eqListBy (eqTypeX env) + check (liftEq (eqTypeX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2)) (text "The datatype contexts do not match") `andThenCheck` eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) @@ -1336,7 +1337,7 @@ checkBootTyCon is_boot tc1 tc2 check (dataConIsInfix c1 == dataConIsInfix c2) (text "The fixities of" <+> pname1 <+> text "differ") `andThenCheck` - check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) + check (liftEq eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) (text "The strictness annotations for" <+> pname1 <+> text "differ") `andThenCheck` check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) @@ -1367,7 +1368,7 @@ checkBootTyCon is_boot tc1 tc2 , cab_lhs = lhs2, cab_rhs = rhs2 }) | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 , Just env <- eqVarBndrs env1 cvs1 cvs2 - = eqListBy (eqTypeX env) lhs1 lhs2 && + = liftEq (eqTypeX env) lhs1 lhs2 && eqTypeX env rhs1 rhs2 | otherwise = False diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index f11bc29000..f57580d3ec 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -353,7 +353,7 @@ zonkEnvIds (ZonkEnv { ze_id_env = id_env}) -- immediately by creating a TypeEnv zonkLIdOcc :: ZonkEnv -> LocatedN TcId -> LocatedN Id -zonkLIdOcc env = mapLoc (zonkIdOcc env) +zonkLIdOcc env = fmap (zonkIdOcc env) zonkIdOcc :: ZonkEnv -> TcId -> Id -- Ids defined in this module should be in the envt; @@ -1178,7 +1178,7 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap ; (env1, bind_op') <- zonkSyntaxExpr env bind_op ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts - ; by' <- fmapMaybeM (zonkLExpr env2) by + ; by' <- traverse (zonkLExpr env2) by ; using' <- zonkLExpr env2 using ; (env3, return_op') <- zonkSyntaxExpr env2 return_op diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs index 90e3d1a0c9..5fe9a71955 100644 --- a/compiler/GHC/Types/Avail.hs +++ b/compiler/GHC/Types/Avail.hs @@ -48,13 +48,14 @@ import GHC.Utils.Binary import GHC.Data.List.SetOps import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Misc import GHC.Utils.Constants (debugIsOn) import Data.Data ( Data ) import Data.Either ( partitionEithers ) +import Data.Functor.Classes ( liftCompare ) import Data.List ( find ) import Data.Maybe +import qualified Data.Semigroup as S -- ----------------------------------------------------------------------------- -- The AvailInfo type @@ -166,8 +167,7 @@ See also Note [GreNames] in GHC.Types.Name.Reader. stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering stableAvailCmp (Avail c1) (Avail c2) = c1 `stableGreNameCmp` c2 stableAvailCmp (Avail {}) (AvailTC {}) = LT -stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp` - (cmpList stableGreNameCmp ns ms) +stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableGreNameCmp ns ms stableAvailCmp (AvailTC {}) (Avail {}) = GT stableGreNameCmp :: GreName -> GreName -> Ordering diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index 3d18d7bbb0..9f82fd42a8 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -101,6 +101,7 @@ import GHC.Utils.Panic import Control.DeepSeq import Data.Data +import qualified Data.Semigroup as S {- ************************************************************************ @@ -535,7 +536,7 @@ cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 stableNameCmp :: Name -> Name -> Ordering stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) (Name { n_sort = s2, n_occ = occ2 }) - = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) + = sort_cmp s1 s2 S.<> compare occ1 occ2 -- The ordinary compare on OccNames is lexicographic where -- Later constructors are bigger diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index 45f45a6c9f..f056e833dd 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -114,6 +114,7 @@ import GHC.Utils.Binary import Control.DeepSeq import Data.Char import Data.Data +import qualified Data.Semigroup as S {- ************************************************************************ @@ -245,8 +246,7 @@ instance Eq OccName where instance Ord OccName where -- Compares lexicographically, *not* by Unique of the string - compare (OccName sp1 s1) (OccName sp2 s2) - = (s1 `lexicalCompareFS` s2) `thenCmp` (sp1 `compare` sp2) + compare (OccName sp1 s1) (OccName sp2 s2) = lexicalCompareFS s1 s2 S.<> compare sp1 sp2 instance Data OccName where -- don't traverse? diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index ece56cb5ec..e131415fa3 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -97,6 +97,7 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Data.Data import Data.List( sortBy ) +import qualified Data.Semigroup as S import GHC.Data.Bag {- @@ -341,10 +342,10 @@ instance Ord RdrName where compare (Qual _ _) (Exact _) = GT compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 compare (Qual _ _) (Orig _ _) = LT - compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 compare (Orig _ _) _ = GT {- @@ -1245,8 +1246,7 @@ bestImport iss -- earlier declaration wins over later best (ImpSpec { is_item = item1, is_decl = d1 }) (ImpSpec { is_item = item2, is_decl = d2 }) - = (is_qual d1 `compare` is_qual d2) `thenCmp` - (best_item item1 item2) `thenCmp` + = (is_qual d1 `compare` is_qual d2) S.<> best_item item1 item2 S.<> SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2) best_item :: ImpItemSpec -> ImpItemSpec -> Ordering diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index fdf4423544..bcf47dcaff 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -84,9 +84,6 @@ module GHC.Types.SrcLoc ( pprLocated, pprLocatedAlways, - -- ** Modifying Located - mapLoc, - -- ** Combining and comparing Located values eqLocated, cmpLocated, cmpBufSpan, combineLocs, addCLoc, @@ -95,8 +92,6 @@ module GHC.Types.SrcLoc ( sortLocated, sortRealLocated, lookupSrcLoc, lookupSrcSpan, - liftL, - -- * Parser locations PsLoc(..), PsSpan(..), @@ -129,7 +124,7 @@ import Data.Data import Data.List (sortBy, intercalate) import Data.Function (on) import qualified Data.Map as Map -import qualified Data.Semigroup +import qualified Data.Semigroup as S {- ************************************************************************ @@ -637,9 +632,7 @@ srcSpanToRealSrcSpan _ = Nothing -- We want to order RealSrcSpans first by the start point, then by the -- end point. instance Ord RealSrcSpan where - a `compare` b = - (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` - (realSrcSpanEnd a `compare` realSrcSpanEnd b) + compare = on compare realSrcSpanStart S.<> on compare realSrcSpanEnd instance Show RealSrcLoc where show (SrcLoc filename row col) @@ -740,9 +733,6 @@ data GenLocated l e = L l e type Located = GenLocated SrcSpan type RealLocated = GenLocated RealSrcSpan -mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b -mapLoc = fmap - unLoc :: GenLocated l e -> e unLoc (L _ e) = e @@ -821,10 +811,8 @@ pprLocatedAlways (L l e) = leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering rightmost_smallest = compareSrcSpanBy (flip compare) leftmost_smallest = compareSrcSpanBy compare -leftmost_largest = compareSrcSpanBy $ \a b -> - (realSrcSpanStart a `compare` realSrcSpanStart b) - `thenCmp` - (realSrcSpanEnd b `compare` realSrcSpanEnd a) +leftmost_largest = compareSrcSpanBy $ + on compare realSrcSpanStart S.<> flip (on compare realSrcSpanEnd) compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b @@ -854,11 +842,6 @@ isRealSubspanOf src parent | otherwise = realSrcSpanStart parent <= realSrcSpanStart src && realSrcSpanEnd parent >= realSrcSpanEnd src -liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b) -liftL f (L loc a) = do - a' <- f a - return $ L loc a' - getRealSrcSpan :: RealLocated a -> RealSrcSpan getRealSrcSpan (L l _) = l diff --git a/compiler/GHC/Unit/Module.hs b/compiler/GHC/Unit/Module.hs index 7ae0059b71..030dd5a39f 100644 --- a/compiler/GHC/Unit/Module.hs +++ b/compiler/GHC/Unit/Module.hs @@ -49,10 +49,11 @@ import GHC.Types.Unique.DSet import GHC.Unit.Types import GHC.Unit.Module.Location import GHC.Unit.Module.Env -import GHC.Utils.Misc import Language.Haskell.Syntax.Module.Name +import Data.Semigroup + -- | A 'Module' is definite if it has no free holes. moduleIsDefinite :: Module -> Bool moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles @@ -69,9 +70,7 @@ moduleStableString Module{..} = -- gives an ordering based on the 'Unique's of the components, which may -- not be stable from run to run of the compiler. stableModuleCmp :: Module -> Module -> Ordering -stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stableUnitCmp` p2) `thenCmp` - (n1 `stableModuleNameCmp` n2) +stableModuleCmp (Module p1 n1) (Module p2 n2) = stableUnitCmp p1 p2 <> stableModuleNameCmp n1 n2 class ContainsModule t where extractModule :: t -> Module diff --git a/compiler/GHC/Unit/Module/Env.hs b/compiler/GHC/Unit/Module/Env.hs index 2fc0f9e9c1..0c0559e206 100644 --- a/compiler/GHC/Unit/Module/Env.hs +++ b/compiler/GHC/Unit/Module/Env.hs @@ -41,7 +41,6 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Unit.Types -import GHC.Utils.Misc import Data.List (sortBy, sort) import Data.Ord @@ -50,6 +49,7 @@ import Data.Map (Map) import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Semigroup as S import qualified GHC.Data.FiniteMap as Map import GHC.Utils.Outputable @@ -87,7 +87,7 @@ instance Outputable NDModule where instance Ord NDModule where compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = - (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` + (getUnique p1 `nonDetCmpUnique` getUnique p2) S.<> (getUnique n1 `nonDetCmpUnique` getUnique n2) filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index e9f7685a92..2701565cc8 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -4,7 +4,6 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} @@ -29,7 +28,6 @@ module GHC.Utils.Misc ( mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, filterOut, partitionWith, - mapAccumM, dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, @@ -59,10 +57,8 @@ module GHC.Utils.Misc ( -- * Tuples fstOf3, sndOf3, thdOf3, - firstM, first3M, secondM, fst3, snd3, third3, uncurry3, - liftFst, liftSnd, -- * List operations controlled by another list takeList, dropList, splitAtList, split, @@ -72,8 +68,7 @@ module GHC.Utils.Misc ( sortWith, minWith, nubSort, ordNub, ordNubOn, -- * Comparisons - isEqual, eqListBy, eqMaybeBy, - thenCmp, cmpList, + isEqual, removeSpaces, (<&&>), (<||>), @@ -141,12 +136,13 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import GHC.Exts import GHC.Stack (HasCallStack) -import Control.Monad ( liftM, guard ) +import Control.Monad ( guard ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) import System.FilePath +import Data.Bifunctor ( first, second ) import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper , isHexDigit, digitToInt ) import Data.Int @@ -158,9 +154,6 @@ import qualified Data.Set as Set import Data.Time -infixr 9 `thenCmp` - - {- ************************************************************************ * * @@ -202,21 +195,6 @@ third3 f (a, b, c) = (a, b, f c) uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c -liftFst :: (a -> b) -> (a, c) -> (b, c) -liftFst f (a,c) = (f a, c) - -liftSnd :: (a -> b) -> (c, a) -> (c, b) -liftSnd f (c,a) = (c, f a) - -firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) -firstM f (x, y) = liftM (\x' -> (x', y)) (f x) - -first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) -first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) - -secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) -secondM f (x, y) = (x,) <$> f y - {- ************************************************************************ * * @@ -349,11 +327,11 @@ stretchZipWith p z f (x:xs) ys [] -> [] (y:ys) -> f x y : stretchZipWith p z f xs ys -mapFst :: (a->c) -> [(a,b)] -> [(c,b)] -mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] +mapFst :: Functor f => (a->c) -> f(a,b) -> f(c,b) +mapSnd :: Functor f => (b->c) -> f(a,b) -> f(a,c) -mapFst f xys = [(f x, y) | (x,y) <- xys] -mapSnd f xys = [(x, f y) | (x,y) <- xys] +mapFst = fmap . first +mapSnd = fmap . second mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) @@ -541,15 +519,6 @@ mapLastM _ [] = panic "mapLastM: empty list" mapLastM f [x] = (\x' -> [x']) <$> f x mapLastM f (x:xs) = (x:) <$> mapLastM f xs -mapAccumM :: (Monad m) => (r -> a -> m (r, b)) -> r -> [a] -> m (r, [b]) -mapAccumM f = go - where - go acc [] = pure (acc,[]) - go acc (x:xs) = do - (acc',y) <- f acc x - (acc'',ys) <- go acc' xs - pure (acc'', y:ys) - whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] _ = pure () whenNonEmpty (x:xs) f = f (x :| xs) @@ -824,30 +793,6 @@ isEqual GT = False isEqual EQ = True isEqual LT = False -thenCmp :: Ordering -> Ordering -> Ordering -{-# INLINE thenCmp #-} -thenCmp EQ ordering = ordering -thenCmp ordering _ = ordering - -eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool -eqListBy _ [] [] = True -eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys -eqListBy _ _ _ = False - -eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool -eqMaybeBy _ Nothing Nothing = True -eqMaybeBy eq (Just x) (Just y) = eq x y -eqMaybeBy _ _ _ = False - -cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering - -- `cmpList' uses a user-specified comparer - -cmpList _ [] [] = EQ -cmpList _ [] _ = LT -cmpList _ _ [] = GT -cmpList cmp (a:as) (b:bs) - = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } - removeSpaces :: String -> String removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace @@ -1006,7 +951,7 @@ fuzzyLookup user_entered possibilities -} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] -unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs +unzipWith = fmap . uncurry seqList :: [a] -> b -> b seqList [] b = b diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs index d814fe9c92..b0605b96b0 100644 --- a/compiler/GHC/Utils/Monad.hs +++ b/compiler/GHC/Utils/Monad.hs @@ -11,16 +11,12 @@ module GHC.Utils.Monad , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M , mapAccumLM - , liftFstM, liftSndM , mapSndM , concatMapM , mapMaybeM - , fmapMaybeM, fmapEitherM , anyM, allM, orM , foldlM, foldlM_, foldrM - , maybeMapM , whenM, unlessM - , filterOutM ) where ------------------------------------------------------------------------------- @@ -161,17 +157,8 @@ mapAccumLM f s xs = go s [] = return (s, []) -- | Monadic version of mapSnd -mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] -mapSndM f xs = go xs - where - go [] = return [] - go ((a,b):xs) = do { c <- f b; rs <- go xs; return ((a,c):rs) } - -liftFstM :: Monad m => (a -> b) -> m (a, r) -> m (b, r) -liftFstM f thing = do { (a,r) <- thing; return (f a, r) } - -liftSndM :: Monad m => (a -> b) -> m (r, a) -> m (r, b) -liftSndM f thing = do { (r,a) <- thing; return (r, f a) } +mapSndM :: (Applicative m, Traversable f) => (b -> m c) -> f (a,b) -> m (f (a,c)) +mapSndM = traverse . traverse -- | Monadic version of concatMap concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] @@ -182,16 +169,6 @@ mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f = foldr g (pure []) where g a = liftA2 (maybe id (:)) (f a) --- | Monadic version of fmap -fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) -fmapMaybeM _ Nothing = return Nothing -fmapMaybeM f (Just x) = f x >>= (return . Just) - --- | Monadic version of fmap -fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) -fmapEitherM fl _ (Left a) = fl a >>= (return . Left) -fmapEitherM _ fr (Right b) = fr b >>= (return . Right) - -- | Monadic version of 'any', aborts the computation at the first @True@ value anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM f xs = go xs @@ -216,11 +193,6 @@ orM m1 m2 = m1 >>= \x -> if x then return True else m2 foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () foldlM_ = foldM_ --- | Monadic version of fmap specialised for Maybe -maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) -maybeMapM _ Nothing = return Nothing -maybeMapM m (Just x) = liftM Just $ m x - -- | Monadic version of @when@, taking the condition in the monad whenM :: Monad m => m Bool -> m () -> m () whenM mb thing = do { b <- mb @@ -231,11 +203,6 @@ unlessM :: Monad m => m Bool -> m () -> m () unlessM condM acc = do { cond <- condM ; unless cond acc } --- | Like 'filterM', only it reverses the sense of the test. -filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] -filterOutM p = - foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) - {- Note [The one-shot state monad trick] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Summary: many places in GHC use a state monad, and we really want those diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 3751711b9d..3cf0c642c6 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -132,6 +132,7 @@ import qualified Data.IntMap.Strict as IntMap import Data.Time.LocalTime ( getZonedTime ) import Data.Time.Format ( formatTime, defaultTimeLocale ) import Data.Version ( showVersion ) +import qualified Data.Semigroup as S import Prelude hiding ((<>)) import GHC.Utils.Exception as Exception hiding (catch, mask, handle) @@ -1416,9 +1417,7 @@ printTypeOfNames names = mapM_ (printTypeOfName ) $ sortBy compareNames names compareNames :: Name -> Name -> Ordering -n1 `compareNames` n2 = - (compare `on` getOccString) n1 n2 `thenCmp` - (SrcLoc.leftmost_smallest `on` getSrcSpan) n1 n2 +compareNames = on compare getOccString S.<> on SrcLoc.leftmost_smallest getSrcSpan printTypeOfName :: GHC.GhcMonad m => Name -> m () printTypeOfName n @@ -3844,10 +3843,7 @@ enclosingTickSpan md (RealSrcSpan src _) = do where leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering -leftmostLargestRealSrcSpan a b = - (realSrcSpanStart a `compare` realSrcSpanStart b) - `thenCmp` - (realSrcSpanEnd b `compare` realSrcSpanEnd a) +leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd traceCmd :: GhciMonad m => String -> m () traceCmd arg diff --git a/utils/haddock b/utils/haddock -Subproject a9a312991e55ab99a8dee36a6747f4fc5d5b7c6 +Subproject 43f478af894b5173b4f1087c6d92c41a64250be |