{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}

-----------------------------------------------------------------------------

-- |

-- Module      :  Data.Functor.Extend

-- Copyright   :  (C) 2011-2015 Edward Kmett

-- License     :  BSD-style (see the file LICENSE)

--

-- Maintainer  :  Edward Kmett <ekmett@gmail.com>

-- Stability   :  provisional

-- Portability :  portable

--

----------------------------------------------------------------------------

module Data.Functor.Extend
  ( -- * Extendable Functors

    -- $definition

    Extend(..)
  , gduplicated
  , gextended
  ) where

import Prelude hiding (id, (.))
import Control.Category
import Control.Monad.Trans.Identity
import Data.Functor.Identity
import Data.Functor.Sum as Functor (Sum(..))
import Data.List (tails)
import Data.List.NonEmpty (NonEmpty(..), toList)
import Data.Orphans ()
import qualified Data.Monoid as Monoid
import Data.Proxy
import Data.Semigroup as Semigroup
import GHC.Generics as Generics

#ifdef MIN_VERSION_containers
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Tree
#endif

#ifdef MIN_VERSION_comonad
import Control.Comonad.Trans.Env
import Control.Comonad.Trans.Store
import Control.Comonad.Trans.Traced
#endif

#ifdef MIN_VERSION_tagged
import Data.Tagged
#endif

class Functor w => Extend w where
  -- |

  -- > duplicated = extended id

  -- > fmap (fmap f) . duplicated = duplicated . fmap f

  duplicated :: w a -> w (w a)
  -- |

  -- > extended f  = fmap f . duplicated

  extended    :: (w a -> b) -> w a -> w b

  extended w a -> b
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap w a -> b
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (w :: * -> *) a. Extend w => w a -> w (w a)
duplicated
  duplicated = forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

  {-# MINIMAL duplicated | extended #-}

-- | Generic 'duplicated'. Caveats:

--

--   1. Will not compile if @w@ is a product type.

--   2. Will not compile if @w@ contains fields where the type variable appears underneath the composition of type constructors (e.g., @f (g a)@).

--

-- @since 5.3.8

gduplicated :: (Extend (Rep1 w), Generic1 w) => w a -> w (w a)
gduplicated :: forall (w :: * -> *) a.
(Extend (Rep1 w), Generic1 w) =>
w a -> w (w a)
gduplicated = forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (w :: * -> *) a. Extend w => w a -> w (w a)
duplicated forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1

-- | Generic 'extended'. Caveats are the same as for 'gduplicated'.

--

-- @since 5.3.8

gextended :: (Extend (Rep1 w), Generic1 w) => (w a -> b) -> w a -> w b
gextended :: forall (w :: * -> *) a b.
(Extend (Rep1 w), Generic1 w) =>
(w a -> b) -> w a -> w b
gextended w a -> b
f = forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (w a -> b
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1

-- * Extends for Prelude types:

--

-- Instances: While Data.Functor.Extend.Instances would be symmetric

-- to the definition of Control.Monad.Instances in base, the reason

-- the latter exists is because of Haskell 98 specifying the types

-- @'Either' a@, @((,)m)@ and @((->)e)@ and the class Monad without

-- having the foresight to require or allow instances between them.

--

-- Here Haskell 98 says nothing about Extend, so we can include the

-- instances directly avoiding the wart of orphan instances.


instance Extend [] where
  duplicated :: forall a. [a] -> [[a]]
duplicated = forall a. [a] -> [a]
init forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. [a] -> [[a]]
tails

#ifdef MIN_VERSION_tagged
instance Extend (Tagged a) where
  duplicated :: forall a. Tagged a a -> Tagged a (Tagged a a)
duplicated = forall {k} (s :: k) b. b -> Tagged s b
Tagged
#endif

instance Extend Proxy where
  duplicated :: forall a. Proxy a -> Proxy (Proxy a)
duplicated Proxy a
_ = forall {k} (t :: k). Proxy t
Proxy
  extended :: forall a b. (Proxy a -> b) -> Proxy a -> Proxy b
extended Proxy a -> b
_ Proxy a
_ = forall {k} (t :: k). Proxy t
Proxy

instance Extend Maybe where
  duplicated :: forall a. Maybe a -> Maybe (Maybe a)
duplicated Maybe a
Nothing = forall a. Maybe a
Nothing
  duplicated Maybe a
j = forall a. a -> Maybe a
Just Maybe a
j

instance Extend (Either a) where
  duplicated :: forall a. Either a a -> Either a (Either a a)
duplicated (Left a
a) = forall a b. a -> Either a b
Left a
a
  duplicated Either a a
r = forall a b. b -> Either a b
Right Either a a
r

instance Extend ((,)e) where
  duplicated :: forall a. (e, a) -> (e, (e, a))
duplicated (e, a)
p = (forall a b. (a, b) -> a
fst (e, a)
p, (e, a)
p)

instance Semigroup m => Extend ((->)m) where
  duplicated :: forall a. (m -> a) -> m -> (m -> a)
duplicated m -> a
f m
m = m -> a
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Semigroup a => a -> a -> a
(<>) m
m

#ifdef MIN_VERSION_containers
instance Extend Seq where
  duplicated :: forall a. Seq a -> Seq (Seq a)
duplicated Seq a
l = forall a. Int -> Seq a -> Seq a
Seq.take (forall a. Seq a -> Int
Seq.length Seq a
l) (forall a. Seq a -> Seq (Seq a)
Seq.tails Seq a
l)

instance Extend Tree where
  duplicated :: forall a. Tree a -> Tree (Tree a)
duplicated w :: Tree a
w@(Node a
_ [Tree a]
as) = forall a. a -> [Tree a] -> Tree a
Node Tree a
w (forall a b. (a -> b) -> [a] -> [b]
map forall (w :: * -> *) a. Extend w => w a -> w (w a)
duplicated [Tree a]
as)
#endif

#ifdef MIN_VERSION_comonad
{-
instance (Extend f, Extend g) => Extend (Coproduct f g) where
  extended f = Coproduct . coproduct
    (Left . extended (f . Coproduct . Left))
    (Right . extended (f . Coproduct . Right))
-}

instance Extend w => Extend (EnvT e w) where
  duplicated :: forall a. EnvT e w a -> EnvT e w (EnvT e w a)
duplicated (EnvT e
e w a
wa) = forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e (forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e) w a
wa)

instance Extend w => Extend (StoreT s w) where
  duplicated :: forall a. StoreT s w a -> StoreT s w (StoreT s w a)
duplicated (StoreT w (s -> a)
wf s
s) = forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT (forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT w (s -> a)
wf) s
s
  extended :: forall a b. (StoreT s w a -> b) -> StoreT s w a -> StoreT s w b
extended StoreT s w a -> b
f (StoreT w (s -> a)
wf s
s) = forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT (forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (\w (s -> a)
wf' s
s' -> StoreT s w a -> b
f (forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT w (s -> a)
wf' s
s')) w (s -> a)
wf) s
s

instance (Extend w, Semigroup m) => Extend (TracedT m w) where
  extended :: forall a b. (TracedT m w a -> b) -> TracedT m w a -> TracedT m w b
extended TracedT m w a -> b
f = forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (\w (m -> a)
wf m
m -> TracedT m w a -> b
f (forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Semigroup a => a -> a -> a
(<>) m
m) w (m -> a)
wf))) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall m (w :: * -> *) a. TracedT m w a -> w (m -> a)
runTracedT
#endif

-- I can't fix the world

-- instance (Monoid m, Extend n) => Extend (ReaderT m n)

--   duplicate f m = f . mappend m


-- * Extends for types from 'transformers'.

--

-- This isn't really a transformer, so i have no compunction about including the instance here.

--

-- TODO: Petition to move Data.Functor.Identity into base

instance Extend Identity where
  duplicated :: forall a. Identity a -> Identity (Identity a)
duplicated = forall a. a -> Identity a
Identity

-- Provided to avoid an orphan instance. Not proposed to standardize.

-- If Extend moved to base, consider moving instance into transformers?

instance Extend w => Extend (IdentityT w) where
  extended :: forall a b. (IdentityT w a -> b) -> IdentityT w a -> IdentityT w b
extended IdentityT w a -> b
f (IdentityT w a
m) = forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT (forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (IdentityT w a -> b
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT) w a
m)

instance Extend NonEmpty where
  extended :: forall a b. (NonEmpty a -> b) -> NonEmpty a -> NonEmpty b
extended NonEmpty a -> b
f w :: NonEmpty a
w@(~(a
_ :| [a]
aas)) =
    NonEmpty a -> b
f NonEmpty a
w forall a. a -> [a] -> NonEmpty a
:| case [a]
aas of
      []     -> []
      (a
a:[a]
as) -> forall a. NonEmpty a -> [a]
toList (forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended NonEmpty a -> b
f (a
a forall a. a -> [a] -> NonEmpty a
:| [a]
as))

instance (Extend f, Extend g) => Extend (Functor.Sum f g) where
  extended :: forall a b. (Sum f g a -> b) -> Sum f g a -> Sum f g b
extended Sum f g a -> b
f (InL f a
l) = forall {k} (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL (forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (Sum f g a -> b
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL) f a
l)
  extended Sum f g a -> b
f (InR g a
r) = forall {k} (f :: k -> *) (g :: k -> *) (a :: k). g a -> Sum f g a
InR (forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (Sum f g a -> b
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} (f :: k -> *) (g :: k -> *) (a :: k). g a -> Sum f g a
InR) g a
r)

instance (Extend f, Extend g) => Extend (f :+: g) where
  extended :: forall a b. ((:+:) f g a -> b) -> (:+:) f g a -> (:+:) f g b
extended (:+:) f g a -> b
f (L1 f a
l) = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended ((:+:) f g a -> b
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) f a
l)
  extended (:+:) f g a -> b
f (R1 g a
r) = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended ((:+:) f g a -> b
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1) g a
r)

-- | @since 5.3.8

instance Extend (Generics.K1 i c) where
  duplicated :: forall a. K1 i c a -> K1 i c (K1 i c a)
duplicated (K1 c
c) = forall k i c (p :: k). c -> K1 i c p
K1 c
c

instance Extend Generics.U1 where
  extended :: forall a b. (U1 a -> b) -> U1 a -> U1 b
extended U1 a -> b
_ U1 a
U1 = forall k (p :: k). U1 p
U1

instance Extend Generics.V1 where
  extended :: forall a b. (V1 a -> b) -> V1 a -> V1 b
extended V1 a -> b
_ V1 a
e = case V1 a
e of {}

instance Extend f => Extend (Generics.M1 i t f) where
  extended :: forall a b. (M1 i t f a -> b) -> M1 i t f a -> M1 i t f b
extended M1 i t f a -> b
f = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (M1 i t f a -> b
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance Extend Par1 where
  extended :: forall a b. (Par1 a -> b) -> Par1 a -> Par1 b
extended Par1 a -> b
f w :: Par1 a
w@Par1{} = forall p. p -> Par1 p
Par1 (Par1 a -> b
f Par1 a
w)

instance Extend f => Extend (Rec1 f) where
  extended :: forall a b. (Rec1 f a -> b) -> Rec1 f a -> Rec1 f b
extended Rec1 f a -> b
f = forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (Rec1 f a -> b
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k (f :: k -> *) (p :: k). Rec1 f p -> f p
unRec1

instance Extend Monoid.Sum where
  extended :: forall a b. (Sum a -> b) -> Sum a -> Sum b
extended Sum a -> b
f w :: Sum a
w@Monoid.Sum{} = forall a. a -> Sum a
Monoid.Sum (Sum a -> b
f Sum a
w)

instance Extend Monoid.Product where
  extended :: forall a b. (Product a -> b) -> Product a -> Product b
extended Product a -> b
f w :: Product a
w@Monoid.Product{} = forall a. a -> Product a
Monoid.Product (Product a -> b
f Product a
w)

instance Extend Monoid.Dual where
  extended :: forall a b. (Dual a -> b) -> Dual a -> Dual b
extended Dual a -> b
f w :: Dual a
w@Monoid.Dual{} = forall a. a -> Dual a
Monoid.Dual (Dual a -> b
f Dual a
w)

instance Extend f => Extend (Monoid.Alt f) where
  extended :: forall a b. (Alt f a -> b) -> Alt f a -> Alt f b
extended Alt f a -> b
f = forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Monoid.Alt forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (Alt f a -> b
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Monoid.Alt) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} (f :: k -> *) (a :: k). Alt f a -> f a
Monoid.getAlt

-- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way

instance Extend Semigroup.First where
  extended :: forall a b. (First a -> b) -> First a -> First b
extended First a -> b
f w :: First a
w@Semigroup.First{} = forall a. a -> First a
Semigroup.First (First a -> b
f First a
w)

instance Extend Semigroup.Last where
  extended :: forall a b. (Last a -> b) -> Last a -> Last b
extended Last a -> b
f w :: Last a
w@Semigroup.Last{} = forall a. a -> Last a
Semigroup.Last (Last a -> b
f Last a
w)

instance Extend Semigroup.Min where
  extended :: forall a b. (Min a -> b) -> Min a -> Min b
extended Min a -> b
f w :: Min a
w@Semigroup.Min{} = forall a. a -> Min a
Semigroup.Min (Min a -> b
f Min a
w)

instance Extend Semigroup.Max where
  extended :: forall a b. (Max a -> b) -> Max a -> Max b
extended Max a -> b
f w :: Max a
w@Semigroup.Max{} = forall a. a -> Max a
Semigroup.Max (Max a -> b
f Max a
w)

-- $definition

-- There are two ways to define an 'Extend' instance:

--

-- I. Provide definitions for 'extended'

-- satisfying this law:

--

-- > extended f . extended g = extended (f . extended g)

--

-- II. Alternately, you may choose to provide definitions for 'duplicated'

-- satisfying this law:

--

-- > duplicated . duplicated = fmap duplicated . duplicated

--

-- You may of course, choose to define both 'duplicated' /and/ 'extended'.

-- In that case you must also satisfy these laws:

--

-- > extended f = fmap f . duplicated

-- > duplicated = extended id

--

-- These are the default definitions of 'extended' and 'duplicated'.