{-# LANGUAGE CPP         #-}
{-# LANGUAGE Trustworthy #-}
module Data.Crosswalk (
    -- * Crosswalk
    Crosswalk (..),
    -- * Bicrosswalk
    Bicrosswalk (..),
    ) where

import Control.Applicative   (pure, (<$>))
import Data.Bifoldable       (Bifoldable (..))
import Data.Bifunctor        (Bifunctor (..))
import Data.Foldable         (Foldable (..))
import Data.Functor.Compose  (Compose (..))
import Data.Functor.Identity (Identity (..))
import Data.Vector.Generic   (Vector)
import Prelude               (Either (..), Functor (fmap), Maybe (..), id, (.))

import qualified Data.Sequence       as Seq
import qualified Data.Vector         as V
import qualified Data.Vector.Generic as VG

import Data.Align
import Data.These

-- --------------------------------------------------------------------------
-- | Foldable functors supporting traversal through an alignable
--   functor.
--
--   Minimal definition: @crosswalk@ or @sequenceL@.
--
--   Laws:
--
-- @
-- crosswalk (const nil) = const nil
-- crosswalk f = sequenceL . fmap f
-- @
class (Functor t, Foldable t) => Crosswalk t where
    crosswalk :: (Align f) => (a -> f b) -> t a -> f (t b)
    crosswalk a -> f b
f = t (f b) -> f (t b)
forall (t :: * -> *) (f :: * -> *) a.
(Crosswalk t, Align f) =>
t (f a) -> f (t a)
sequenceL (t (f b) -> f (t b)) -> (t a -> t (f b)) -> t a -> f (t b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> t a -> t (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> f b
f

    sequenceL :: (Align f) => t (f a) -> f (t a)
    sequenceL = (f a -> f a) -> t (f a) -> f (t a)
forall (t :: * -> *) (f :: * -> *) a b.
(Crosswalk t, Align f) =>
(a -> f b) -> t a -> f (t b)
crosswalk f a -> f a
forall a. a -> a
id

#if __GLASGOW_HASKELL__ >= 707
    {-# MINIMAL crosswalk | sequenceL #-}
#endif

instance Crosswalk Identity where
    crosswalk :: (a -> f b) -> Identity a -> f (Identity b)
crosswalk a -> f b
f (Identity a
a) = (b -> Identity b) -> f b -> f (Identity b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Identity b
forall a. a -> Identity a
Identity (a -> f b
f a
a)

instance Crosswalk Maybe where
    crosswalk :: (a -> f b) -> Maybe a -> f (Maybe b)
crosswalk a -> f b
_ Maybe a
Nothing = f (Maybe b)
forall (f :: * -> *) a. Align f => f a
nil
    crosswalk a -> f b
f (Just a
a) = b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> f b -> f (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a

instance Crosswalk [] where
    crosswalk :: (a -> f b) -> [a] -> f [b]
crosswalk a -> f b
_ [] = f [b]
forall (f :: * -> *) a. Align f => f a
nil
    crosswalk a -> f b
f (a
x:[a]
xs) = (These b [b] -> [b]) -> f b -> f [b] -> f [b]
forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
alignWith These b [b] -> [b]
forall a. These a [a] -> [a]
cons (a -> f b
f a
x) ((a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Crosswalk t, Align f) =>
(a -> f b) -> t a -> f (t b)
crosswalk a -> f b
f [a]
xs)
      where cons :: These a [a] -> [a]
cons = (a -> [a])
-> ([a] -> [a]) -> (a -> [a] -> [a]) -> These a [a] -> [a]
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a] -> [a]
forall a. a -> a
id (:)

instance Crosswalk Seq.Seq where
    crosswalk :: (a -> f b) -> Seq a -> f (Seq b)
crosswalk a -> f b
f = (a -> f (Seq b) -> f (Seq b)) -> f (Seq b) -> Seq a -> f (Seq b)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((These b (Seq b) -> Seq b) -> f b -> f (Seq b) -> f (Seq b)
forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
alignWith These b (Seq b) -> Seq b
forall a. These a (Seq a) -> Seq a
cons (f b -> f (Seq b) -> f (Seq b))
-> (a -> f b) -> a -> f (Seq b) -> f (Seq b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) f (Seq b)
forall (f :: * -> *) a. Align f => f a
nil where
        cons :: These a (Seq a) -> Seq a
cons = (a -> Seq a)
-> (Seq a -> Seq a)
-> (a -> Seq a -> Seq a)
-> These a (Seq a)
-> Seq a
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these a -> Seq a
forall a. a -> Seq a
Seq.singleton Seq a -> Seq a
forall a. a -> a
id a -> Seq a -> Seq a
forall a. a -> Seq a -> Seq a
(Seq.<|)

instance Crosswalk (These a) where
    crosswalk :: (a -> f b) -> These a a -> f (These a b)
crosswalk a -> f b
_ (This a
_) = f (These a b)
forall (f :: * -> *) a. Align f => f a
nil
    crosswalk a -> f b
f (That a
x) = b -> These a b
forall a b. b -> These a b
That (b -> These a b) -> f b -> f (These a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
    crosswalk a -> f b
f (These a
a a
x) = a -> b -> These a b
forall a b. a -> b -> These a b
These a
a (b -> These a b) -> f b -> f (These a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x

crosswalkVector :: (Vector v a, Vector v b, Align f)
    => (a -> f b) -> v a -> f (v b)
crosswalkVector :: (a -> f b) -> v a -> f (v b)
crosswalkVector a -> f b
f = ([b] -> v b) -> f [b] -> f (v b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [b] -> v b
forall (v :: * -> *) a. Vector v a => [a] -> v a
VG.fromList (f [b] -> f (v b)) -> (v a -> f [b]) -> v a -> f (v b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f [b] -> f [b]) -> f [b] -> v a -> f [b]
forall (v :: * -> *) a b.
Vector v a =>
(a -> b -> b) -> b -> v a -> b
VG.foldr ((These b [b] -> [b]) -> f b -> f [b] -> f [b]
forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
alignWith These b [b] -> [b]
forall a. These a [a] -> [a]
cons (f b -> f [b] -> f [b]) -> (a -> f b) -> a -> f [b] -> f [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) f [b]
forall (f :: * -> *) a. Align f => f a
nil where
    cons :: These a [a] -> [a]
cons = (a -> [a])
-> ([a] -> [a]) -> (a -> [a] -> [a]) -> These a [a] -> [a]
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a] -> [a]
forall a. a -> a
id (:)

instance Crosswalk V.Vector where
    crosswalk :: (a -> f b) -> Vector a -> f (Vector b)
crosswalk = (a -> f b) -> Vector a -> f (Vector b)
forall (v :: * -> *) a b (f :: * -> *).
(Vector v a, Vector v b, Align f) =>
(a -> f b) -> v a -> f (v b)
crosswalkVector

instance Crosswalk ((,) a) where
    crosswalk :: (a -> f b) -> (a, a) -> f (a, b)
crosswalk a -> f b
fun (a
a, a
x) = (b -> (a, b)) -> f b -> f (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) a
a) (a -> f b
fun a
x)

-- can't (shouldn't) do longer tuples until there are Functor and Foldable
-- instances for them

instance (Crosswalk f, Crosswalk g) => Crosswalk (Compose f g) where
    crosswalk :: (a -> f b) -> Compose f g a -> f (Compose f g b)
crosswalk a -> f b
f
        = (f (g b) -> Compose f g b) -> f (f (g b)) -> f (Compose f g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (g b) -> Compose f g b
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose -- can't coerce: maybe the Align-able thing has role nominal
        (f (f (g b)) -> f (Compose f g b))
-> (Compose f g a -> f (f (g b)))
-> Compose f g a
-> f (Compose f g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g a -> f (g b)) -> f (g a) -> f (f (g b))
forall (t :: * -> *) (f :: * -> *) a b.
(Crosswalk t, Align f) =>
(a -> f b) -> t a -> f (t b)
crosswalk ((a -> f b) -> g a -> f (g b)
forall (t :: * -> *) (f :: * -> *) a b.
(Crosswalk t, Align f) =>
(a -> f b) -> t a -> f (t b)
crosswalk a -> f b
f)
        (f (g a) -> f (f (g b)))
-> (Compose f g a -> f (g a)) -> Compose f g a -> f (f (g b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose f g a -> f (g a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose

-- --------------------------------------------------------------------------
-- | Bifoldable bifunctors supporting traversal through an alignable
--   functor.
--
--   Minimal definition: @bicrosswalk@ or @bisequenceL@.
--
--   Laws:
--
-- @
-- bicrosswalk (const empty) (const empty) = const empty
-- bicrosswalk f g = bisequenceL . bimap f g
-- @
class (Bifunctor t, Bifoldable t) => Bicrosswalk t where
    bicrosswalk :: (Align f) => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
    bicrosswalk a -> f c
f b -> f d
g = t (f c) (f d) -> f (t c d)
forall (t :: * -> * -> *) (f :: * -> *) a b.
(Bicrosswalk t, Align f) =>
t (f a) (f b) -> f (t a b)
bisequenceL (t (f c) (f d) -> f (t c d))
-> (t a b -> t (f c) (f d)) -> t a b -> f (t c d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f c) -> (b -> f d) -> t a b -> t (f c) (f d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> f c
f b -> f d
g

    bisequenceL :: (Align f) => t (f a) (f b) -> f (t a b)
    bisequenceL = (f a -> f a) -> (f b -> f b) -> t (f a) (f b) -> f (t a b)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bicrosswalk t, Align f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bicrosswalk f a -> f a
forall a. a -> a
id f b -> f b
forall a. a -> a
id

#if __GLASGOW_HASKELL__ >= 707
    {-# MINIMAL bicrosswalk | bisequenceL #-}
#endif


instance Bicrosswalk Either where
    bicrosswalk :: (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
bicrosswalk a -> f c
f b -> f d
_ (Left a
x)  = c -> Either c d
forall a b. a -> Either a b
Left  (c -> Either c d) -> f c -> f (Either c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
x
    bicrosswalk a -> f c
_ b -> f d
g (Right b
x) = d -> Either c d
forall a b. b -> Either a b
Right (d -> Either c d) -> f d -> f (Either c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f d
g b
x

instance Bicrosswalk These where
    bicrosswalk :: (a -> f c) -> (b -> f d) -> These a b -> f (These c d)
bicrosswalk a -> f c
f b -> f d
_ (This a
x) = c -> These c d
forall a b. a -> These a b
This (c -> These c d) -> f c -> f (These c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
x
    bicrosswalk a -> f c
_ b -> f d
g (That b
x) = d -> These c d
forall a b. b -> These a b
That (d -> These c d) -> f d -> f (These c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f d
g b
x
    bicrosswalk a -> f c
f b -> f d
g (These a
x b
y) = f c -> f d -> f (These c d)
forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align (a -> f c
f a
x) (b -> f d
g b
y)