{-# 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 = forall (t :: * -> *) (f :: * -> *) a.
(Crosswalk t, Align f) =>
t (f a) -> f (t a)
sequenceL forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *) (f :: * -> *) a b.
(Crosswalk t, Align f) =>
(a -> f b) -> t a -> f (t b)
crosswalk forall a. a -> a
id

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

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

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

instance Crosswalk [] where
    crosswalk :: forall (f :: * -> *) a b. Align f => (a -> f b) -> [a] -> f [b]
crosswalk a -> f b
_ [] = forall (f :: * -> *) a. Align f => f a
nil
    crosswalk a -> f b
f (a
x:[a]
xs) = forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
alignWith forall {a}. These a [a] -> [a]
cons (a -> f b
f a
x) (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 = forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id (:)

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

instance Crosswalk (These a) where
    crosswalk :: forall (f :: * -> *) a b.
Align f =>
(a -> f b) -> These a a -> f (These a b)
crosswalk a -> f b
_ (This a
_) = forall (f :: * -> *) a. Align f => f a
nil
    crosswalk a -> f b
f (That a
x) = forall a b. b -> These a b
That 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) = forall a b. a -> b -> These a b
These a
a 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 :: forall (v :: * -> *) a b (f :: * -> *).
(Vector v a, Vector v b, Align f) =>
(a -> f b) -> v a -> f (v b)
crosswalkVector a -> f b
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (v :: * -> *) a. Vector v a => [a] -> v a
VG.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) a b.
Vector v a =>
(a -> b -> b) -> b -> v a -> b
VG.foldr (forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
alignWith forall {a}. These a [a] -> [a]
cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) forall (f :: * -> *) a. Align f => f a
nil where
    cons :: These a [a] -> [a]
cons = forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id (:)

instance Crosswalk V.Vector where
    crosswalk :: forall (f :: * -> *) a b.
Align f =>
(a -> f b) -> Vector a -> f (Vector b)
crosswalk = 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 :: forall (f :: * -> *) a b.
Align f =>
(a -> f b) -> (a, a) -> f (a, b)
crosswalk a -> f b
fun (a
a, a
x) = 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 :: forall (f :: * -> *) a b.
Align f =>
(a -> f b) -> Compose f g a -> f (Compose f g b)
crosswalk a -> f b
f
        = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Crosswalk t, Align f) =>
(a -> f b) -> t a -> f (t b)
crosswalk (forall (t :: * -> *) (f :: * -> *) a b.
(Crosswalk t, Align f) =>
(a -> f b) -> t a -> f (t b)
crosswalk a -> f b
f)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (f :: k1 -> *) (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 = forall (t :: * -> * -> *) (f :: * -> *) a b.
(Bicrosswalk t, Align f) =>
t (f a) (f b) -> f (t a b)
bisequenceL forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 forall a. a -> a
id forall a. a -> a
id

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


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

instance Bicrosswalk These where
    bicrosswalk :: forall (f :: * -> *) a c b d.
Align f =>
(a -> f c) -> (b -> f d) -> These a b -> f (These c d)
bicrosswalk a -> f c
f b -> f d
_ (This a
x) = forall a b. a -> These a b
This 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) = forall a b. b -> These a b
That 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) = 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)