{-# LANGUAGE CPP #-}

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

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2011-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  polykinds
--
----------------------------------------------------------------------------

module Data.Semigroupoid.Static
  ( Static(..)
  ) where

import Control.Arrow
import Control.Applicative
import Control.Category
import Control.Monad (ap)
import Data.Functor.Apply
import Data.Functor.Plus
import Data.Functor.Extend
import Data.Orphans ()
import Data.Semigroup
import Data.Semigroupoid
import Prelude hiding ((.), id)

#ifdef LANGUAGE_DeriveDataTypeable
import Data.Typeable
#endif

#ifdef MIN_VERSION_comonad
import Control.Comonad
#endif

newtype Static f a b = Static { Static f a b -> f (a -> b)
runStatic :: f (a -> b) }
#ifdef LANGUAGE_DeriveDataTypeable
  deriving (Typeable)
#endif

instance Functor f => Functor (Static f a) where
  fmap :: (a -> b) -> Static f a a -> Static f a b
fmap a -> b
f = f (a -> b) -> Static f a b
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static (f (a -> b) -> Static f a b)
-> (Static f a a -> f (a -> b)) -> Static f a a -> Static 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
. ((a -> a) -> a -> b) -> f (a -> a) -> f (a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f (a -> b) -> (a -> a) -> 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 -> a) -> f (a -> b))
-> (Static f a a -> f (a -> a)) -> Static f a 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
. Static f a a -> f (a -> a)
forall (f :: * -> *) a b. Static f a b -> f (a -> b)
runStatic

instance Apply f => Apply (Static f a) where
  Static f (a -> a -> b)
f <.> :: Static f a (a -> b) -> Static f a a -> Static f a b
<.> Static f (a -> a)
g = f (a -> b) -> Static f a b
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((a -> a -> b) -> (a -> a) -> a -> b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap ((a -> a -> b) -> (a -> a) -> a -> b)
-> f (a -> a -> b) -> f ((a -> a) -> a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a -> a -> b)
f f ((a -> a) -> a -> b) -> f (a -> a) -> f (a -> b)
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f (a -> a)
g)

instance Alt f => Alt (Static f a) where
  Static f (a -> a)
f <!> :: Static f a a -> Static f a a -> Static f a a
<!> Static f (a -> a)
g = f (a -> a) -> Static f a a
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static (f (a -> a)
f f (a -> a) -> f (a -> a) -> f (a -> a)
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> f (a -> a)
g)

instance Plus f => Plus (Static f a) where
  zero :: Static f a a
zero = f (a -> a) -> Static f a a
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static f (a -> a)
forall (f :: * -> *) a. Plus f => f a
zero

instance Applicative f => Applicative (Static f a) where
  pure :: a -> Static f a a
pure = f (a -> a) -> Static f a a
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static (f (a -> a) -> Static f a a)
-> (a -> f (a -> a)) -> a -> Static f 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) -> f (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> a) -> f (a -> a)) -> (a -> a -> a) -> a -> f (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 -> a
forall a b. a -> b -> a
const
  Static f (a -> a -> b)
f <*> :: Static f a (a -> b) -> Static f a a -> Static f a b
<*> Static f (a -> a)
g = f (a -> b) -> Static f a b
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((a -> a -> b) -> (a -> a) -> a -> b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap ((a -> a -> b) -> (a -> a) -> a -> b)
-> f (a -> a -> b) -> f ((a -> a) -> a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a -> a -> b)
f f ((a -> a) -> a -> b) -> f (a -> a) -> f (a -> b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (a -> a)
g)

instance (Extend f, Semigroup a) => Extend (Static f a) where
  extended :: (Static f a a -> b) -> Static f a a -> Static f a b
extended Static f a a -> b
f = f (a -> b) -> Static f a b
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static (f (a -> b) -> Static f a b)
-> (Static f a a -> f (a -> b)) -> Static f a a -> Static 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 -> a) -> a -> b) -> f (a -> a) -> f (a -> b)
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (\f (a -> a)
wf a
m -> Static f a a -> b
f (f (a -> a) -> Static f a a
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static (((a -> a) -> a -> a) -> f (a -> a) -> f (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((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 -> a
forall a. Semigroup a => a -> a -> a
(<>) a
m) f (a -> a)
wf))) (f (a -> a) -> f (a -> b))
-> (Static f a a -> f (a -> a)) -> Static f a 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
. Static f a a -> f (a -> a)
forall (f :: * -> *) a b. Static f a b -> f (a -> b)
runStatic

#ifdef MIN_VERSION_comonad
instance (Comonad f, Monoid a) => Comonad (Static f a) where
  extend :: (Static f a a -> b) -> Static f a a -> Static f a b
extend Static f a a -> b
f = f (a -> b) -> Static f a b
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static (f (a -> b) -> Static f a b)
-> (Static f a a -> f (a -> b)) -> Static f a a -> Static 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 -> a) -> a -> b) -> f (a -> a) -> f (a -> b)
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend (\f (a -> a)
wf a
m -> Static f a a -> b
f (f (a -> a) -> Static f a a
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static (((a -> a) -> a -> a) -> f (a -> a) -> f (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((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 -> a
forall a. Monoid a => a -> a -> a
mappend a
m) f (a -> a)
wf))) (f (a -> a) -> f (a -> b))
-> (Static f a a -> f (a -> a)) -> Static f a 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
. Static f a a -> f (a -> a)
forall (f :: * -> *) a b. Static f a b -> f (a -> b)
runStatic
  extract :: Static f a a -> a
extract (Static f (a -> a)
g) = f (a -> a) -> a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract f (a -> a)
g a
forall a. Monoid a => a
mempty
#endif

instance Apply f => Semigroupoid (Static f) where
  Static f (j -> k)
f o :: Static f j k -> Static f i j -> Static f i k
`o` Static f (i -> j)
g = f (i -> k) -> Static f i k
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((j -> k) -> (i -> j) -> i -> k
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.) ((j -> k) -> (i -> j) -> i -> k)
-> f (j -> k) -> f ((i -> j) -> i -> k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (j -> k)
f f ((i -> j) -> i -> k) -> f (i -> j) -> f (i -> k)
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> f (i -> j)
g)

instance Applicative f => Category (Static f) where
  id :: Static f a a
id = f (a -> a) -> Static f a a
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((a -> a) -> f (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
  Static f (b -> c)
f . :: Static f b c -> Static f a b -> Static f a c
. Static f (a -> b)
g = f (a -> c) -> Static f a c
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((b -> c) -> (a -> b) -> a -> c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.) ((b -> c) -> (a -> b) -> a -> c)
-> f (b -> c) -> f ((a -> b) -> a -> c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b -> c)
f f ((a -> b) -> a -> c) -> f (a -> b) -> f (a -> c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (a -> b)
g)

instance Applicative f => Arrow (Static f) where
  arr :: (b -> c) -> Static f b c
arr = f (b -> c) -> Static f b c
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static (f (b -> c) -> Static f b c)
-> ((b -> c) -> f (b -> c)) -> (b -> c) -> Static f b c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (b -> c) -> f (b -> c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  first :: Static f b c -> Static f (b, d) (c, d)
first (Static f (b -> c)
g) = f ((b, d) -> (c, d)) -> Static f (b, d) (c, d)
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((b -> c) -> (b, d) -> (c, d))
-> f (b -> c) -> f ((b, d) -> (c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b -> c)
g)
  second :: Static f b c -> Static f (d, b) (d, c)
second (Static f (b -> c)
g) = f ((d, b) -> (d, c)) -> Static f (d, b) (d, c)
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((b -> c) -> (d, b) -> (d, c))
-> f (b -> c) -> f ((d, b) -> (d, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b -> c)
g)
  Static f (b -> c)
g *** :: Static f b c -> Static f b' c' -> Static f (b, b') (c, c')
*** Static f (b' -> c')
h = f ((b, b') -> (c, c')) -> Static f (b, b') (c, c')
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***) ((b -> c) -> (b' -> c') -> (b, b') -> (c, c'))
-> f (b -> c) -> f ((b' -> c') -> (b, b') -> (c, c'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b -> c)
g f ((b' -> c') -> (b, b') -> (c, c'))
-> f (b' -> c') -> f ((b, b') -> (c, c'))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (b' -> c')
h)
  Static f (b -> c)
g &&& :: Static f b c -> Static f b c' -> Static f b (c, c')
&&& Static f (b -> c')
h = f (b -> (c, c')) -> Static f b (c, c')
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
(&&&) ((b -> c) -> (b -> c') -> b -> (c, c'))
-> f (b -> c) -> f ((b -> c') -> b -> (c, c'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b -> c)
g f ((b -> c') -> b -> (c, c')) -> f (b -> c') -> f (b -> (c, c'))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (b -> c')
h)

instance Alternative f => ArrowZero (Static f) where
  zeroArrow :: Static f b c
zeroArrow = f (b -> c) -> Static f b c
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static f (b -> c)
forall (f :: * -> *) a. Alternative f => f a
empty

instance Alternative f => ArrowPlus (Static f) where
  Static f (b -> c)
f <+> :: Static f b c -> Static f b c -> Static f b c
<+> Static f (b -> c)
g = f (b -> c) -> Static f b c
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static (f (b -> c)
f f (b -> c) -> f (b -> c) -> f (b -> c)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f (b -> c)
g)

instance Applicative f => ArrowChoice (Static f) where
  left :: Static f b c -> Static f (Either b d) (Either c d)
left (Static f (b -> c)
g) = f (Either b d -> Either c d) -> Static f (Either b d) (Either c d)
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ((b -> c) -> Either b d -> Either c d)
-> f (b -> c) -> f (Either b d -> Either c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b -> c)
g)
  right :: Static f b c -> Static f (Either d b) (Either d c)
right (Static f (b -> c)
g) = f (Either d b -> Either d c) -> Static f (Either d b) (Either d c)
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right ((b -> c) -> Either d b -> Either d c)
-> f (b -> c) -> f (Either d b -> Either d c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b -> c)
g)
  Static f (b -> c)
g +++ :: Static f b c
-> Static f b' c' -> Static f (Either b b') (Either c c')
+++ Static f (b' -> c')
h = f (Either b b' -> Either c c')
-> Static f (Either b b') (Either c c')
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((b -> c) -> (b' -> c') -> Either b b' -> Either c c'
forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
(+++) ((b -> c) -> (b' -> c') -> Either b b' -> Either c c')
-> f (b -> c) -> f ((b' -> c') -> Either b b' -> Either c c')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b -> c)
g f ((b' -> c') -> Either b b' -> Either c c')
-> f (b' -> c') -> f (Either b b' -> Either c c')
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (b' -> c')
h)
  Static f (b -> d)
g ||| :: Static f b d -> Static f c d -> Static f (Either b c) d
||| Static f (c -> d)
h = f (Either b c -> d) -> Static f (Either b c) d
forall (f :: * -> *) a b. f (a -> b) -> Static f a b
Static ((b -> d) -> (c -> d) -> Either b c -> d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
(|||) ((b -> d) -> (c -> d) -> Either b c -> d)
-> f (b -> d) -> f ((c -> d) -> Either b c -> d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b -> d)
g f ((c -> d) -> Either b c -> d)
-> f (c -> d) -> f (Either b c -> d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (c -> d)
h)