From 1219f8e8a3d1b58263bea76822322b746a632778 Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Date: Sat, 8 Jun 2019 20:48:07 +0200
Subject: Use DeriveFunctor throughout the codebase (#15654)

---
 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 +----
 8 files changed, 17 insertions(+), 37 deletions(-)

(limited to 'compiler/utils')

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
-- 
cgit v1.2.1