{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif

#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE EmptyCase #-}
#endif
-----------------------------------------------------------------------------
-- |
-- 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(..)
  ) 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)

#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

#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0)
import Data.Proxy
#endif

#ifdef MIN_VERSION_generic_deriving
import Generics.Deriving.Base as Generics
#else
import GHC.Generics as Generics
#endif

import Data.Orphans ()
import qualified Data.Monoid as Monoid
import Data.Semigroup as Semigroup

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 = (w a -> b) -> w (w a) -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap w a -> b
f (w (w a) -> w b) -> (w a -> w (w a)) -> w a -> w b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. w a -> w (w a)
forall (w :: * -> *) a. Extend w => w a -> w (w a)
duplicated
  duplicated = (w a -> w a) -> w a -> w (w a)
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended w a -> w a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

#if __GLASGOW_HASKELL__ >= 708
  {-# MINIMAL duplicated | extended #-}
#endif

-- * 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 :: [a] -> [[a]]
duplicated = [[a]] -> [[a]]
forall a. [a] -> [a]
init ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [a] -> [[a]]
forall a. [a] -> [[a]]
tails

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

#if defined(MIN_VERSION_tagged) || MIN_VERSION_base(4,7,0)
instance Extend Proxy where
  duplicated :: Proxy a -> Proxy (Proxy a)
duplicated Proxy a
_ = Proxy (Proxy a)
forall k (t :: k). Proxy t
Proxy
  extended :: (Proxy a -> b) -> Proxy a -> Proxy b
extended Proxy a -> b
_ Proxy a
_ = Proxy b
forall k (t :: k). Proxy t
Proxy
#endif

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

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

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

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

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

instance Extend Tree where
  duplicated :: Tree a -> Tree (Tree a)
duplicated w :: Tree a
w@(Node a
_ [Tree a]
as) = Tree a -> [Tree (Tree a)] -> Tree (Tree a)
forall a. a -> [Tree a] -> Tree a
Node Tree a
w ((Tree a -> Tree (Tree a)) -> [Tree a] -> [Tree (Tree a)]
forall a b. (a -> b) -> [a] -> [b]
map Tree a -> Tree (Tree a)
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 :: EnvT e w a -> EnvT e w (EnvT e w a)
duplicated (EnvT e
e w a
wa) = e -> w (EnvT e w a) -> EnvT e w (EnvT e w a)
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e ((w a -> EnvT e w a) -> w a -> w (EnvT e w a)
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (e -> w a -> EnvT e w a
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 :: StoreT s w a -> StoreT s w (StoreT s w a)
duplicated (StoreT w (s -> a)
wf s
s) = w (s -> StoreT s w a) -> s -> StoreT s w (StoreT s w a)
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT ((w (s -> a) -> s -> StoreT s w a)
-> w (s -> a) -> w (s -> StoreT s w a)
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended w (s -> a) -> s -> StoreT s w a
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT w (s -> a)
wf) s
s
  extended :: (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) = w (s -> b) -> s -> StoreT s w b
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT ((w (s -> a) -> s -> b) -> w (s -> a) -> w (s -> b)
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 (w (s -> a) -> s -> StoreT s w a
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 :: (TracedT m w a -> b) -> TracedT m w a -> TracedT m w b
extended TracedT m w a -> b
f = w (m -> b) -> TracedT m w b
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (w (m -> b) -> TracedT m w b)
-> (TracedT m w a -> w (m -> b)) -> TracedT m w a -> TracedT m w b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (w (m -> a) -> m -> b) -> w (m -> a) -> w (m -> b)
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 (w (m -> a) -> TracedT m w a
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (((m -> a) -> m -> a) -> w (m -> a) -> w (m -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m -> a) -> (m -> m) -> m -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m -> m -> m
forall a. Semigroup a => a -> a -> a
(<>) m
m) w (m -> a)
wf))) (w (m -> a) -> w (m -> b))
-> (TracedT m w a -> w (m -> a)) -> TracedT m w a -> w (m -> b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TracedT m w a -> w (m -> a)
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 :: Identity a -> Identity (Identity a)
duplicated = Identity a -> Identity (Identity a)
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 :: (IdentityT w a -> b) -> IdentityT w a -> IdentityT w b
extended IdentityT w a -> b
f (IdentityT w a
m) = w b -> IdentityT w b
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT ((w a -> b) -> w a -> w b
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (IdentityT w a -> b
f (IdentityT w a -> b) -> (w a -> IdentityT w a) -> w a -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. w a -> IdentityT w a
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT) w a
m)

instance Extend NonEmpty where
  extended :: (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 b -> [b] -> NonEmpty b
forall a. a -> [a] -> NonEmpty a
:| case [a]
aas of
      []     -> []
      (a
a:[a]
as) -> NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
toList ((NonEmpty a -> b) -> NonEmpty a -> NonEmpty b
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended NonEmpty a -> b
f (a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
as))

instance (Extend f, Extend g) => Extend (Functor.Sum f g) where
  extended :: (Sum f g a -> b) -> Sum f g a -> Sum f g b
extended Sum f g a -> b
f (InL f a
l) = f b -> Sum f g b
forall k (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL ((f a -> b) -> f a -> f b
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (Sum f g a -> b
f (Sum f g a -> b) -> (f a -> Sum f g a) -> f a -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f a -> Sum f g a
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) = g b -> Sum f g b
forall k (f :: k -> *) (g :: k -> *) (a :: k). g a -> Sum f g a
InR ((g a -> b) -> g a -> g b
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (Sum f g a -> b
f (Sum f g a -> b) -> (g a -> Sum f g a) -> g a -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. g a -> Sum f g a
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 :: ((:+:) f g a -> b) -> (:+:) f g a -> (:+:) f g b
extended (:+:) f g a -> b
f (L1 f a
l) = f b -> (:+:) f g b
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 ((f a -> b) -> f a -> f b
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended ((:+:) f g a -> b
f ((:+:) f g a -> b) -> (f a -> (:+:) f g a) -> f a -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f a -> (:+:) f g a
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) = g b -> (:+:) f g b
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 ((g a -> b) -> g a -> g b
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended ((:+:) f g a -> b
f ((:+:) f g a -> b) -> (g a -> (:+:) f g a) -> g a -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1) g a
r)

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

instance Extend Generics.V1 where
#if __GLASGOW_HASKELL__ >= 708
  extended :: (V1 a -> b) -> V1 a -> V1 b
extended V1 a -> b
_ V1 a
e = case V1 a
e of {}
#else
  extended _ e = seq e undefined
#endif

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

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

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

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

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

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

#if MIN_VERSION_base(4,8,0)
instance Extend f => Extend (Monoid.Alt f) where
  extended :: (Alt f a -> b) -> Alt f a -> Alt f b
extended Alt f a -> b
f = f b -> Alt f b
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Monoid.Alt (f b -> Alt f b) -> (Alt f a -> f b) -> Alt f a -> Alt f b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (f a -> b) -> f a -> f b
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (Alt f a -> b
f (Alt f a -> b) -> (f a -> Alt f a) -> f a -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f a -> Alt f a
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Monoid.Alt) (f a -> f b) -> (Alt f a -> f a) -> Alt f a -> f b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Alt f a -> f a
forall k (f :: k -> *) (a :: k). Alt f a -> f a
Monoid.getAlt
#endif

-- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way
instance Extend Semigroup.First where
  extended :: (First a -> b) -> First a -> First b
extended First a -> b
f w :: First a
w@Semigroup.First{} = b -> First b
forall a. a -> First a
Semigroup.First (First a -> b
f First a
w)

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

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

instance Extend Semigroup.Max where
  extended :: (Max a -> b) -> Max a -> Max b
extended Max a -> b
f w :: Max a
w@Semigroup.Max{} = b -> Max b
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'.