Skip to content
Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
189 lines (155 sloc) 4.02 KB
-- | Generic deriving for standard classes in base
{-# LANGUAGE FlexibleContexts #-}
module Generic.Data.Internal.Prelude where
import Control.Applicative (liftA2, Alternative(..))
import Data.Function (on)
import Data.Functor.Classes
import Data.Semigroup
import GHC.Generics
import Generic.Data.Internal.Utils (from', to', liftG2)
-- * 'Eq'
-- | Generic @('==')@.
--
-- @
-- instance 'Eq' MyType where
-- ('==') = 'geq'
-- @
geq :: (Generic a, Eq (Rep a ())) => a -> a -> Bool
geq = (==) `on` from'
-- * 'Ord'
-- | Generic 'compare'.
--
-- @
-- instance 'Ord' MyType where
-- 'compare' = 'gcompare'
-- @
gcompare :: (Generic a, Ord (Rep a ())) => a -> a -> Ordering
gcompare = compare `on` from'
-- * 'Semigroup'
-- | Generic @('<>')@ (or 'mappend').
--
-- @
-- instance 'Semigroup' MyType where
-- ('<>') = 'gmappend'
-- @
--
-- See also 'gmempty'.
gmappend :: (Generic a, Semigroup (Rep a ())) => a -> a -> a
gmappend = \a b -> to (from' a <> from' b)
-- * 'Monoid'
-- | Generic 'mempty'.
--
-- @
-- instance 'Monoid' MyType where
-- 'mempty' = 'gmempty'
-- @
gmempty :: (Generic a, Monoid (Rep a ())) => a
gmempty = to' mempty
-- | Generic @('<>')@ (or @'mappend'@).
--
-- The difference from `gmappend' is the 'Monoid' constraint instead of
-- 'Semigroup', for older versions of base where 'Semigroup' is not a
-- superclass of 'Monoid'.
gmappend' :: (Generic a, Monoid (Rep a ())) => a -> a -> a
gmappend' = \a b -> to (from' a `mappend` from' b)
-- * 'Functor'
-- | Generic 'fmap'.
--
-- @
-- instance 'Functor' MyTypeF where
-- 'fmap' = 'gfmap'
-- @
gfmap :: (Generic1 f, Functor (Rep1 f)) => (a -> b) -> f a -> f b
gfmap = \f -> to1 . fmap f . from1
-- | Generic @('<$')@.
--
-- See also 'gfmap'.
gconstmap :: (Generic1 f, Functor (Rep1 f)) => a -> f b -> f a
gconstmap = \a -> to1 . (a <$) . from1
-- * 'Applicative'
-- | Generic 'pure'.
--
-- @
-- instance 'Applicative' MyTypeF where
-- 'pure' = 'gpure'
-- ('<*>') = 'gap'
-- @
gpure :: (Generic1 f, Applicative (Rep1 f)) => a -> f a
gpure = to1 . pure
-- | Generic @('<*>')@ (or 'Control.Monad.ap').
--
-- See also 'gpure'.
gap :: (Generic1 f, Applicative (Rep1 f)) => f (a -> b) -> f a -> f b
gap = liftG2 (<*>)
-- | Generic 'liftA2'.
--
-- See also 'gpure'.
gliftA2 :: (Generic1 f, Applicative (Rep1 f)) => (a -> b -> c) -> f a -> f b -> f c
gliftA2 = liftG2 . liftA2
-- * 'Alternative'
-- | Generic 'empty'.
--
-- @
-- instance 'Alternative' MyTypeF where
-- 'empty' = 'gempty'
-- ('<|>') = 'galt'
-- @
gempty :: (Generic1 f, Alternative (Rep1 f)) => f a
gempty = to1 empty
-- | Generic ('<|>').
--
-- See also 'gempty'.
galt :: (Generic1 f, Alternative (Rep1 f)) => f a -> f a -> f a
galt = liftG2 (<|>)
-- * 'Foldable'
-- | Generic 'foldMap'.
--
-- @
-- instance 'Foldable' MyTypeF where
-- 'foldMap' = 'gfoldMap'
-- @
gfoldMap :: (Generic1 f, Foldable (Rep1 f), Monoid m) => (a -> m) -> f a -> m
gfoldMap = \f -> foldMap f . from1
-- | Generic 'foldr'.
--
-- @
-- instance 'Foldable' MyTypeF where
-- 'foldr' = 'gfoldr'
-- @
--
-- See also 'gfoldMap'.
gfoldr :: (Generic1 f, Foldable (Rep1 f)) => (a -> b -> b) -> b -> f a -> b
gfoldr = \f b -> foldr f b . from1
-- * 'Traversable'
-- | Generic 'traverse'.
--
-- @
-- instance 'Traversable' MyTypeF where
-- 'traverse' = 'gtraverse'
-- @
gtraverse
:: (Generic1 f, Traversable (Rep1 f), Applicative m)
=> (a -> m b) -> f a -> m (f b)
gtraverse = \f -> fmap to1 . traverse f . from1
-- | Generic 'sequenceA'.
--
-- @
-- instance 'Traversable' MyTypeF where
-- 'sequenceA' = 'gsequenceA'
-- @
--
-- See also 'gtraverse'.
gsequenceA
:: (Generic1 f, Traversable (Rep1 f), Applicative m)
=> f (m a) -> m (f a)
gsequenceA = fmap to1 . sequenceA . from1
-- * 'Eq1'
-- | Generic 'liftEq'.
gliftEq :: (Generic1 f, Eq1 (Rep1 f)) => (a -> b -> Bool) -> f a -> f b -> Bool
gliftEq = \(==.) a b -> liftEq (==.) (from1 a) (from1 b)
-- * 'Ord1'
-- | Generic 'liftCompare'.
gliftCompare
:: (Generic1 f, Ord1 (Rep1 f))
=> (a -> b -> Ordering) -> f a -> f b -> Ordering
gliftCompare = \compare' a b -> liftCompare compare' (from1 a) (from1 b)
You can’t perform that action at this time.