Simplify instance declarations

Many instance declarations can now be derived either by DerivingVia or
GeneralizedNewtypeDeriving.
This commit is contained in:
Tony Zorman 2022-11-19 09:10:57 +01:00
parent 5d0013ef53
commit b96bb908db
4 changed files with 20 additions and 47 deletions

View File

@ -1,4 +1,6 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_HADDOCK show-extensions #-} {-# OPTIONS_HADDOCK show-extensions #-}
@ -355,23 +357,8 @@ focusLockOff = XS.modify (const (FocusLock False))
-- | Monad on top of 'Query' providing additional information about new -- | Monad on top of 'Query' providing additional information about new
-- window. -- window.
newtype FocusQuery a = FocusQuery (ReaderT Focus Query a) newtype FocusQuery a = FocusQuery (ReaderT Focus Query a)
instance Functor FocusQuery where deriving newtype (Functor, Applicative, Monad, MonadReader Focus, MonadIO)
fmap f (FocusQuery x) = FocusQuery (fmap f x) deriving (Semigroup, Monoid) via Ap FocusQuery a
instance Applicative FocusQuery where
pure x = FocusQuery (pure x)
(FocusQuery f) <*> (FocusQuery mx) = FocusQuery (f <*> mx)
instance Monad FocusQuery where
(FocusQuery mx) >>= f = FocusQuery $ mx >>= \x ->
let FocusQuery y = f x in y
instance MonadReader Focus FocusQuery where
ask = FocusQuery ask
local f (FocusQuery mx) = FocusQuery (local f mx)
instance MonadIO FocusQuery where
liftIO mx = FocusQuery (liftIO mx)
instance Semigroup a => Semigroup (FocusQuery a) where
(<>) = liftM2 (<>)
instance Monoid a => Monoid (FocusQuery a) where
mempty = return mempty
runFocusQuery :: FocusQuery a -> Focus -> Query a runFocusQuery :: FocusQuery a -> Focus -> Query a
runFocusQuery (FocusQuery m) = runReaderT m runFocusQuery (FocusQuery m) = runReaderT m

View File

@ -1,3 +1,4 @@
{-# LANGUAGE DerivingVia #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : XMonad.Hooks.WorkspaceHistory -- Module : XMonad.Hooks.WorkspaceHistory
@ -63,14 +64,9 @@ import qualified XMonad.Util.ExtensibleState as XS
newtype WorkspaceHistory = WorkspaceHistory newtype WorkspaceHistory = WorkspaceHistory
{ history :: [(ScreenId, WorkspaceId)] -- ^ Workspace Screens in { history :: [(ScreenId, WorkspaceId)] -- ^ Workspace Screens in
-- reverse-chronological order. -- reverse-chronological order.
} deriving (Read, Show) }
deriving (Read, Show)
-- @ScreenId@ is not an instance of NFData, but is a newtype on @Int@. @seq@ deriving NFData via [(Int, WorkspaceId)]
-- is enough for forcing it. This requires us to provide an instance.
instance NFData WorkspaceHistory where
rnf (WorkspaceHistory hist) =
let go = liftRnf2 rwhnf rwhnf
in liftRnf go hist
instance ExtensionClass WorkspaceHistory where instance ExtensionClass WorkspaceHistory where
initialValue = WorkspaceHistory [] initialValue = WorkspaceHistory []

View File

@ -1,4 +1,8 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} {-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : XMonad.Layout.Mosaic -- Module : XMonad.Layout.Mosaic
@ -179,16 +183,7 @@ normalize :: Fractional a => [a] -> [a]
normalize x = let s = sum x in map (/s) x normalize x = let s = sum x in map (/s) x
data Tree a = Branch (Tree a) (Tree a) | Leaf a | Empty data Tree a = Branch (Tree a) (Tree a) | Leaf a | Empty
deriving (Functor, Show, Foldable)
instance Foldable Tree where
foldMap _f Empty = mempty
foldMap f (Leaf x) = f x
foldMap f (Branch l r) = foldMap f l `mappend` foldMap f r
instance Functor Tree where
fmap f (Leaf x) = Leaf $ f x
fmap f (Branch l r) = Branch (fmap f l) (fmap f r)
fmap _ Empty = Empty
instance Semigroup (Tree a) where instance Semigroup (Tree a) where
Empty <> x = x Empty <> x = x

View File

@ -1,4 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-} {-# LANGUAGE DerivingVia, GeneralizedNewtypeDeriving, FlexibleContexts #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
@ -110,12 +110,7 @@ import Control.Monad.Reader
-- | The @PureX@ newtype over @ReaderT XConf (State XState) a@. -- | The @PureX@ newtype over @ReaderT XConf (State XState) a@.
newtype PureX a = PureX (ReaderT XConf (State XState) a) newtype PureX a = PureX (ReaderT XConf (State XState) a)
deriving (Functor, Applicative, Monad, MonadReader XConf, MonadState XState) deriving (Functor, Applicative, Monad, MonadReader XConf, MonadState XState)
deriving (Semigroup, Monoid) via Ap PureX a
instance Semigroup a => Semigroup (PureX a) where
(<>) = liftA2 (<>)
instance Monoid a => Monoid (PureX a) where
mempty = return mempty
-- | The @XLike@ typeclass over monads reading @XConf@ values and tracking -- | The @XLike@ typeclass over monads reading @XConf@ values and tracking
-- @XState@ state. -- @XState@ state.