{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE AutoDeriveTypeable #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Constant
-- Copyright   :  (c) Ross Paterson 2010
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  R.Paterson@city.ac.uk
-- Stability   :  experimental
-- Portability :  portable
--
-- The constant functor.
-----------------------------------------------------------------------------

module Data.Functor.Constant (
    Constant(..),
  ) where

import Data.Functor.Classes
#if MIN_VERSION_base(4,12,0)
import Data.Functor.Contravariant
#endif

import Control.Applicative
import Data.Foldable
import Data.Monoid (Monoid(..))
import Data.Traversable (Traversable(traverse))
#if MIN_VERSION_base(4,8,0)
import Data.Bifunctor (Bifunctor(..))
#endif
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup(..))
#endif
#if MIN_VERSION_base(4,10,0)
import Data.Bifoldable (Bifoldable(..))
import Data.Bitraversable (Bitraversable(..))
#endif
import Prelude hiding (null, length)

-- | Constant functor.
newtype Constant a b = Constant { Constant a b -> a
getConstant :: a }
    deriving (Constant a b -> Constant a b -> Bool
(Constant a b -> Constant a b -> Bool)
-> (Constant a b -> Constant a b -> Bool) -> Eq (Constant a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a k (b :: k). Eq a => Constant a b -> Constant a b -> Bool
/= :: Constant a b -> Constant a b -> Bool
$c/= :: forall a k (b :: k). Eq a => Constant a b -> Constant a b -> Bool
== :: Constant a b -> Constant a b -> Bool
$c== :: forall a k (b :: k). Eq a => Constant a b -> Constant a b -> Bool
Eq, Eq (Constant a b)
Eq (Constant a b)
-> (Constant a b -> Constant a b -> Ordering)
-> (Constant a b -> Constant a b -> Bool)
-> (Constant a b -> Constant a b -> Bool)
-> (Constant a b -> Constant a b -> Bool)
-> (Constant a b -> Constant a b -> Bool)
-> (Constant a b -> Constant a b -> Constant a b)
-> (Constant a b -> Constant a b -> Constant a b)
-> Ord (Constant a b)
Constant a b -> Constant a b -> Bool
Constant a b -> Constant a b -> Ordering
Constant a b -> Constant a b -> Constant a b
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a k (b :: k). Ord a => Eq (Constant a b)
forall a k (b :: k). Ord a => Constant a b -> Constant a b -> Bool
forall a k (b :: k).
Ord a =>
Constant a b -> Constant a b -> Ordering
forall a k (b :: k).
Ord a =>
Constant a b -> Constant a b -> Constant a b
min :: Constant a b -> Constant a b -> Constant a b
$cmin :: forall a k (b :: k).
Ord a =>
Constant a b -> Constant a b -> Constant a b
max :: Constant a b -> Constant a b -> Constant a b
$cmax :: forall a k (b :: k).
Ord a =>
Constant a b -> Constant a b -> Constant a b
>= :: Constant a b -> Constant a b -> Bool
$c>= :: forall a k (b :: k). Ord a => Constant a b -> Constant a b -> Bool
> :: Constant a b -> Constant a b -> Bool
$c> :: forall a k (b :: k). Ord a => Constant a b -> Constant a b -> Bool
<= :: Constant a b -> Constant a b -> Bool
$c<= :: forall a k (b :: k). Ord a => Constant a b -> Constant a b -> Bool
< :: Constant a b -> Constant a b -> Bool
$c< :: forall a k (b :: k). Ord a => Constant a b -> Constant a b -> Bool
compare :: Constant a b -> Constant a b -> Ordering
$ccompare :: forall a k (b :: k).
Ord a =>
Constant a b -> Constant a b -> Ordering
$cp1Ord :: forall a k (b :: k). Ord a => Eq (Constant a b)
Ord)

-- These instances would be equivalent to the derived instances of the
-- newtype if the field were removed.

instance (Read a) => Read (Constant a b) where
    readsPrec :: Int -> ReadS (Constant a b)
readsPrec = (String -> ReadS (Constant a b)) -> Int -> ReadS (Constant a b)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (Constant a b)) -> Int -> ReadS (Constant a b))
-> (String -> ReadS (Constant a b)) -> Int -> ReadS (Constant a b)
forall a b. (a -> b) -> a -> b
$
         (Int -> ReadS a)
-> String -> (a -> Constant a b) -> String -> ReadS (Constant a b)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith Int -> ReadS a
forall a. Read a => Int -> ReadS a
readsPrec String
"Constant" a -> Constant a b
forall k a (b :: k). a -> Constant a b
Constant

instance (Show a) => Show (Constant a b) where
    showsPrec :: Int -> Constant a b -> ShowS
showsPrec Int
d (Constant a
x) = (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec String
"Constant" Int
d a
x

-- Instances of lifted Prelude classes

instance Eq2 Constant where
    liftEq2 :: (a -> b -> Bool)
-> (c -> d -> Bool) -> Constant a c -> Constant b d -> Bool
liftEq2 a -> b -> Bool
eq c -> d -> Bool
_ (Constant a
x) (Constant b
y) = a -> b -> Bool
eq a
x b
y
    {-# INLINE liftEq2 #-}

instance Ord2 Constant where
    liftCompare2 :: (a -> b -> Ordering)
-> (c -> d -> Ordering) -> Constant a c -> Constant b d -> Ordering
liftCompare2 a -> b -> Ordering
comp c -> d -> Ordering
_ (Constant a
x) (Constant b
y) = a -> b -> Ordering
comp a
x b
y
    {-# INLINE liftCompare2 #-}

instance Read2 Constant where
    liftReadsPrec2 :: (Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (Constant a b)
liftReadsPrec2 Int -> ReadS a
rp ReadS [a]
_ Int -> ReadS b
_ ReadS [b]
_ = (String -> ReadS (Constant a b)) -> Int -> ReadS (Constant a b)
forall a. (String -> ReadS a) -> Int -> ReadS a
readsData ((String -> ReadS (Constant a b)) -> Int -> ReadS (Constant a b))
-> (String -> ReadS (Constant a b)) -> Int -> ReadS (Constant a b)
forall a b. (a -> b) -> a -> b
$
         (Int -> ReadS a)
-> String -> (a -> Constant a b) -> String -> ReadS (Constant a b)
forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith Int -> ReadS a
rp String
"Constant" a -> Constant a b
forall k a (b :: k). a -> Constant a b
Constant

instance Show2 Constant where
    liftShowsPrec2 :: (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> Constant a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
sp [a] -> ShowS
_ Int -> b -> ShowS
_ [b] -> ShowS
_ Int
d (Constant a
x) = (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> a -> ShowS
sp String
"Constant" Int
d a
x

instance (Eq a) => Eq1 (Constant a) where
    liftEq :: (a -> b -> Bool) -> Constant a a -> Constant a b -> Bool
liftEq = (a -> a -> Bool)
-> (a -> b -> Bool) -> Constant a a -> Constant a b -> Bool
forall (f :: * -> * -> *) a b c d.
Eq2 f =>
(a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
liftEq2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)
    {-# INLINE liftEq #-}
instance (Ord a) => Ord1 (Constant a) where
    liftCompare :: (a -> b -> Ordering) -> Constant a a -> Constant a b -> Ordering
liftCompare = (a -> a -> Ordering)
-> (a -> b -> Ordering) -> Constant a a -> Constant a b -> Ordering
forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
    {-# INLINE liftCompare #-}
instance (Read a) => Read1 (Constant a) where
    liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Constant a a)
liftReadsPrec = (Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS a)
-> ReadS [a]
-> Int
-> ReadS (Constant a a)
forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (f a b)
liftReadsPrec2 Int -> ReadS a
forall a. Read a => Int -> ReadS a
readsPrec ReadS [a]
forall a. Read a => ReadS [a]
readList
    {-# INLINE liftReadsPrec #-}
instance (Show a) => Show1 (Constant a) where
    liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Constant a a -> ShowS
liftShowsPrec = (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int
-> Constant a a
-> ShowS
forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec [a] -> ShowS
forall a. Show a => [a] -> ShowS
showList
    {-# INLINE liftShowsPrec #-}

instance Functor (Constant a) where
    fmap :: (a -> b) -> Constant a a -> Constant a b
fmap a -> b
_ (Constant a
x) = a -> Constant a b
forall k a (b :: k). a -> Constant a b
Constant a
x
    {-# INLINE fmap #-}

instance Foldable (Constant a) where
    foldMap :: (a -> m) -> Constant a a -> m
foldMap a -> m
_ (Constant a
_) = m
forall a. Monoid a => a
mempty
    {-# INLINE foldMap #-}
#if MIN_VERSION_base(4,8,0)
    null :: Constant a a -> Bool
null (Constant a
_) = Bool
True
    length :: Constant a a -> Int
length (Constant a
_) = Int
0
#endif

instance Traversable (Constant a) where
    traverse :: (a -> f b) -> Constant a a -> f (Constant a b)
traverse a -> f b
_ (Constant a
x) = Constant a b -> f (Constant a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Constant a b
forall k a (b :: k). a -> Constant a b
Constant a
x)
    {-# INLINE traverse #-}

#if MIN_VERSION_base(4,9,0)
instance (Semigroup a) => Semigroup (Constant a b) where
    Constant a
x <> :: Constant a b -> Constant a b -> Constant a b
<> Constant a
y = a -> Constant a b
forall k a (b :: k). a -> Constant a b
Constant (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)
    {-# INLINE (<>) #-}
#endif

instance (Monoid a) => Applicative (Constant a) where
    pure :: a -> Constant a a
pure a
_ = a -> Constant a a
forall k a (b :: k). a -> Constant a b
Constant a
forall a. Monoid a => a
mempty
    {-# INLINE pure #-}
    Constant a
x <*> :: Constant a (a -> b) -> Constant a a -> Constant a b
<*> Constant a
y = a -> Constant a b
forall k a (b :: k). a -> Constant a b
Constant (a
x a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
y)
    {-# INLINE (<*>) #-}

instance (Monoid a) => Monoid (Constant a b) where
    mempty :: Constant a b
mempty = a -> Constant a b
forall k a (b :: k). a -> Constant a b
Constant a
forall a. Monoid a => a
mempty
    {-# INLINE mempty #-}
#if !MIN_VERSION_base(4,11,0)
    -- From base-4.11, Monoid(mappend) defaults to Semigroup((<>))
    Constant x `mappend` Constant y = Constant (x `mappend` y)
    {-# INLINE mappend #-}
#endif

#if MIN_VERSION_base(4,8,0)
instance Bifunctor Constant where
    first :: (a -> b) -> Constant a c -> Constant b c
first a -> b
f (Constant a
x) = b -> Constant b c
forall k a (b :: k). a -> Constant a b
Constant (a -> b
f a
x)
    {-# INLINE first #-}
    second :: (b -> c) -> Constant a b -> Constant a c
second b -> c
_ (Constant a
x) = a -> Constant a c
forall k a (b :: k). a -> Constant a b
Constant a
x
    {-# INLINE second #-}
#endif

#if MIN_VERSION_base(4,10,0)
instance Bifoldable Constant where
    bifoldMap :: (a -> m) -> (b -> m) -> Constant a b -> m
bifoldMap a -> m
f b -> m
_ (Constant a
a) = a -> m
f a
a
    {-# INLINE bifoldMap #-}

instance Bitraversable Constant where
    bitraverse :: (a -> f c) -> (b -> f d) -> Constant a b -> f (Constant c d)
bitraverse a -> f c
f b -> f d
_ (Constant a
a) = c -> Constant c d
forall k a (b :: k). a -> Constant a b
Constant (c -> Constant c d) -> f c -> f (Constant c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
a
    {-# INLINE bitraverse #-}
#endif

#if MIN_VERSION_base(4,12,0)
instance Contravariant (Constant a) where
    contramap :: (a -> b) -> Constant a b -> Constant a a
contramap a -> b
_ (Constant a
a) = a -> Constant a a
forall k a (b :: k). a -> Constant a b
Constant a
a
    {-# INLINE contramap #-}
#endif