{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
-- |
-- Module       : Data.Can
-- Copyright    : (c) 2020 Emily Pillmore
-- License      : BSD-3-Clause
--
-- Maintainer   : Emily Pillmore <emilypi@cohomolo.gy>
-- Stability    : Experimental
-- Portability  : CPP, RankNTypes, TypeApplications
--
-- This module contains the definition for the 'Can' datatype. In
-- practice, this type is isomorphic to 'Maybe' 'These' - the type with
-- two possibly non-exclusive values and an empty case.
module Data.Can
( -- * Datatypes
  -- $general
  Can(..)
  -- * Combinators
, canFst
, canSnd
, isOne
, isEno
, isTwo
, isNon
  -- ** Eliminators
, can
  -- * Folding
, foldOnes
, foldEnos
, foldTwos
, gatherCans
  -- * Filtering
, ones
, enos
, twos
, filterOnes
, filterEnos
, filterTwos
, filterNons
  -- * Curry & Uncurry
, canCurry
, canUncurry
  -- * Partitioning
, partitionCans
, partitionAll
, partitionEithers
, mapCans
  -- * Distributivity
, distributeCan
, codistributeCan
  -- * Associativity
, reassocLR
, reassocRL
  -- * Symmetry
, swapCan
) where


import Control.Applicative (Alternative(..))
import Control.DeepSeq (NFData(..))

import Data.Bifunctor
import Data.Bifoldable
import Data.Binary (Binary(..))
import Data.Bitraversable
import Data.Data
import qualified Data.Either as E
import Data.Foldable
import Data.Hashable
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup (Semigroup(..))
#endif

import GHC.Generics

{- $general

Categorically, the 'Can' datatype represents the
<https://ncatlab.org/nlab/show/pointed+object#limits_and_colimits pointed product>
in the category Hask* of pointed Hask types. The category Hask* consists of
Hask types affixed with a dedicated base point of an object along with the object - i.e. @'Maybe' a@ in Hask. Hence, the product is
@(1 + a) * (1 + b) ~ 1 + a + b + a*b@, or @'Maybe' ('Either' ('Either' a b) (a,b))@ in Hask. Pictorially, you can visualize
this as:


@
'Can':
        a
        |
Non +---+---+ (a,b)
        |
        b
@


The fact that we can think about 'Can' as your average product gives us
some reasoning power about how this thing will be able to interact with the
coproduct in Hask*, called 'Wedge'. Namely, facts about currying
@Can a b -> c ~ a -> b -> c@ and distributivity over 'Wedge'
along with other facts about its associativity, commutativity, and
any other analogy with '(,)' that you can think of.
-}


-- | The 'Can' data type represents values with two non-exclusive
-- possibilities, as well as an empty case. This is a product of pointed types -
-- i.e. of 'Maybe' values. The result is a type, @'Can' a b@, which is isomorphic
-- to @'Maybe' ('These' a b)@.
--
data Can a b = Non | One a | Eno b | Two a b
  deriving
    ( Can a b -> Can a b -> Bool
(Can a b -> Can a b -> Bool)
-> (Can a b -> Can a b -> Bool) -> Eq (Can a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => Can a b -> Can a b -> Bool
/= :: Can a b -> Can a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => Can a b -> Can a b -> Bool
== :: Can a b -> Can a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => Can a b -> Can a b -> Bool
Eq, Eq (Can a b)
Eq (Can a b)
-> (Can a b -> Can a b -> Ordering)
-> (Can a b -> Can a b -> Bool)
-> (Can a b -> Can a b -> Bool)
-> (Can a b -> Can a b -> Bool)
-> (Can a b -> Can a b -> Bool)
-> (Can a b -> Can a b -> Can a b)
-> (Can a b -> Can a b -> Can a b)
-> Ord (Can a b)
Can a b -> Can a b -> Bool
Can a b -> Can a b -> Ordering
Can a b -> Can a b -> Can a b
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a b. (Ord a, Ord b) => Eq (Can a b)
forall a b. (Ord a, Ord b) => Can a b -> Can a b -> Bool
forall a b. (Ord a, Ord b) => Can a b -> Can a b -> Ordering
forall a b. (Ord a, Ord b) => Can a b -> Can a b -> Can a b
min :: Can a b -> Can a b -> Can a b
$cmin :: forall a b. (Ord a, Ord b) => Can a b -> Can a b -> Can a b
max :: Can a b -> Can a b -> Can a b
$cmax :: forall a b. (Ord a, Ord b) => Can a b -> Can a b -> Can a b
>= :: Can a b -> Can a b -> Bool
$c>= :: forall a b. (Ord a, Ord b) => Can a b -> Can a b -> Bool
> :: Can a b -> Can a b -> Bool
$c> :: forall a b. (Ord a, Ord b) => Can a b -> Can a b -> Bool
<= :: Can a b -> Can a b -> Bool
$c<= :: forall a b. (Ord a, Ord b) => Can a b -> Can a b -> Bool
< :: Can a b -> Can a b -> Bool
$c< :: forall a b. (Ord a, Ord b) => Can a b -> Can a b -> Bool
compare :: Can a b -> Can a b -> Ordering
$ccompare :: forall a b. (Ord a, Ord b) => Can a b -> Can a b -> Ordering
$cp1Ord :: forall a b. (Ord a, Ord b) => Eq (Can a b)
Ord, ReadPrec [Can a b]
ReadPrec (Can a b)
Int -> ReadS (Can a b)
ReadS [Can a b]
(Int -> ReadS (Can a b))
-> ReadS [Can a b]
-> ReadPrec (Can a b)
-> ReadPrec [Can a b]
-> Read (Can a b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [Can a b]
forall a b. (Read a, Read b) => ReadPrec (Can a b)
forall a b. (Read a, Read b) => Int -> ReadS (Can a b)
forall a b. (Read a, Read b) => ReadS [Can a b]
readListPrec :: ReadPrec [Can a b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [Can a b]
readPrec :: ReadPrec (Can a b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (Can a b)
readList :: ReadS [Can a b]
$creadList :: forall a b. (Read a, Read b) => ReadS [Can a b]
readsPrec :: Int -> ReadS (Can a b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (Can a b)
Read, Int -> Can a b -> ShowS
[Can a b] -> ShowS
Can a b -> String
(Int -> Can a b -> ShowS)
-> (Can a b -> String) -> ([Can a b] -> ShowS) -> Show (Can a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> Can a b -> ShowS
forall a b. (Show a, Show b) => [Can a b] -> ShowS
forall a b. (Show a, Show b) => Can a b -> String
showList :: [Can a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [Can a b] -> ShowS
show :: Can a b -> String
$cshow :: forall a b. (Show a, Show b) => Can a b -> String
showsPrec :: Int -> Can a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> Can a b -> ShowS
Show
    , (forall x. Can a b -> Rep (Can a b) x)
-> (forall x. Rep (Can a b) x -> Can a b) -> Generic (Can a b)
forall x. Rep (Can a b) x -> Can a b
forall x. Can a b -> Rep (Can a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (Can a b) x -> Can a b
forall a b x. Can a b -> Rep (Can a b) x
$cto :: forall a b x. Rep (Can a b) x -> Can a b
$cfrom :: forall a b x. Can a b -> Rep (Can a b) x
Generic, (forall a. Can a a -> Rep1 (Can a) a)
-> (forall a. Rep1 (Can a) a -> Can a a) -> Generic1 (Can a)
forall a. Rep1 (Can a) a -> Can a a
forall a. Can a a -> Rep1 (Can a) a
forall a a. Rep1 (Can a) a -> Can a a
forall a a. Can a a -> Rep1 (Can a) a
forall k (f :: k -> *).
(forall (a :: k). f a -> Rep1 f a)
-> (forall (a :: k). Rep1 f a -> f a) -> Generic1 f
$cto1 :: forall a a. Rep1 (Can a) a -> Can a a
$cfrom1 :: forall a a. Can a a -> Rep1 (Can a) a
Generic1
    , Typeable, Typeable (Can a b)
DataType
Constr
Typeable (Can a b)
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Can a b -> c (Can a b))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Can a b))
-> (Can a b -> Constr)
-> (Can a b -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Can a b)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Can a b)))
-> ((forall b. Data b => b -> b) -> Can a b -> Can a b)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Can a b -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Can a b -> r)
-> (forall u. (forall d. Data d => d -> u) -> Can a b -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Can a b -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Can a b -> m (Can a b))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Can a b -> m (Can a b))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Can a b -> m (Can a b))
-> Data (Can a b)
Can a b -> DataType
Can a b -> Constr
(forall b. Data b => b -> b) -> Can a b -> Can a b
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Can a b -> c (Can a b)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Can a b)
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Can a b))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Can a b -> u
forall u. (forall d. Data d => d -> u) -> Can a b -> [u]
forall a b. (Data a, Data b) => Typeable (Can a b)
forall a b. (Data a, Data b) => Can a b -> DataType
forall a b. (Data a, Data b) => Can a b -> Constr
forall a b.
(Data a, Data b) =>
(forall b. Data b => b -> b) -> Can a b -> Can a b
forall a b u.
(Data a, Data b) =>
Int -> (forall d. Data d => d -> u) -> Can a b -> u
forall a b u.
(Data a, Data b) =>
(forall d. Data d => d -> u) -> Can a b -> [u]
forall a b r r'.
(Data a, Data b) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Can a b -> r
forall a b r r'.
(Data a, Data b) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Can a b -> r
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(forall d. Data d => d -> m d) -> Can a b -> m (Can a b)
forall a b (m :: * -> *).
(Data a, Data b, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Can a b -> m (Can a b)
forall a b (c :: * -> *).
(Data a, Data b) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Can a b)
forall a b (c :: * -> *).
(Data a, Data b) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Can a b -> c (Can a b)
forall a b (t :: * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Can a b))
forall a b (t :: * -> * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Can a b))
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Can a b -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Can a b -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Can a b -> m (Can a b)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Can a b -> m (Can a b)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Can a b)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Can a b -> c (Can a b)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Can a b))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Can a b))
$cTwo :: Constr
$cEno :: Constr
$cOne :: Constr
$cNon :: Constr
$tCan :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Can a b -> m (Can a b)
$cgmapMo :: forall a b (m :: * -> *).
(Data a, Data b, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Can a b -> m (Can a b)
gmapMp :: (forall d. Data d => d -> m d) -> Can a b -> m (Can a b)
$cgmapMp :: forall a b (m :: * -> *).
(Data a, Data b, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Can a b -> m (Can a b)
gmapM :: (forall d. Data d => d -> m d) -> Can a b -> m (Can a b)
$cgmapM :: forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(forall d. Data d => d -> m d) -> Can a b -> m (Can a b)
gmapQi :: Int -> (forall d. Data d => d -> u) -> Can a b -> u
$cgmapQi :: forall a b u.
(Data a, Data b) =>
Int -> (forall d. Data d => d -> u) -> Can a b -> u
gmapQ :: (forall d. Data d => d -> u) -> Can a b -> [u]
$cgmapQ :: forall a b u.
(Data a, Data b) =>
(forall d. Data d => d -> u) -> Can a b -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Can a b -> r
$cgmapQr :: forall a b r r'.
(Data a, Data b) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Can a b -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Can a b -> r
$cgmapQl :: forall a b r r'.
(Data a, Data b) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Can a b -> r
gmapT :: (forall b. Data b => b -> b) -> Can a b -> Can a b
$cgmapT :: forall a b.
(Data a, Data b) =>
(forall b. Data b => b -> b) -> Can a b -> Can a b
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Can a b))
$cdataCast2 :: forall a b (t :: * -> * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Can a b))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (Can a b))
$cdataCast1 :: forall a b (t :: * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Can a b))
dataTypeOf :: Can a b -> DataType
$cdataTypeOf :: forall a b. (Data a, Data b) => Can a b -> DataType
toConstr :: Can a b -> Constr
$ctoConstr :: forall a b. (Data a, Data b) => Can a b -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Can a b)
$cgunfold :: forall a b (c :: * -> *).
(Data a, Data b) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Can a b)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Can a b -> c (Can a b)
$cgfoldl :: forall a b (c :: * -> *).
(Data a, Data b) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Can a b -> c (Can a b)
$cp1Data :: forall a b. (Data a, Data b) => Typeable (Can a b)
Data
    )

-- -------------------------------------------------------------------- --
-- Eliminators

-- | Case elimination for the 'Can' datatype
--
can
    :: c
      -- ^ default value to supply for the 'Non' case
    -> (a -> c)
      -- ^ eliminator for the 'One' case
    -> (b -> c)
      -- ^ eliminator for the 'Eno' case
    -> (a -> b -> c)
      -- ^ eliminator for the 'Two' case
    -> Can a b
    -> c
can :: c -> (a -> c) -> (b -> c) -> (a -> b -> c) -> Can a b -> c
can c
c a -> c
_ b -> c
_ a -> b -> c
_ Can a b
Non = c
c
can c
_ a -> c
f b -> c
_ a -> b -> c
_ (One a
a) = a -> c
f a
a
can c
_ a -> c
_ b -> c
g a -> b -> c
_ (Eno b
b) = b -> c
g b
b
can c
_ a -> c
_ b -> c
_ a -> b -> c
h (Two a
a b
b) = a -> b -> c
h a
a b
b

-- -------------------------------------------------------------------- --
-- Combinators

-- | Project the left value of a 'Can' datatype. This is analogous
-- to 'fst' for '(,)'.
--
canFst :: Can a b -> Maybe a
canFst :: Can a b -> Maybe a
canFst = \case
  One a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
  Two a
a b
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
  Can a b
_ -> Maybe a
forall a. Maybe a
Nothing

-- | Project the right value of a 'Can' datatype. This is analogous
-- to 'snd' for '(,)'.
--
canSnd :: Can a b -> Maybe b
canSnd :: Can a b -> Maybe b
canSnd = \case
  Eno b
b -> b -> Maybe b
forall a. a -> Maybe a
Just b
b
  Two a
_ b
b -> b -> Maybe b
forall a. a -> Maybe a
Just b
b
  Can a b
_ -> Maybe b
forall a. Maybe a
Nothing

-- | Detect if a 'Can' is a 'One' case.
--
isOne :: Can a b -> Bool
isOne :: Can a b -> Bool
isOne (One a
_) = Bool
True
isOne Can a b
_ = Bool
False

-- | Detect if a 'Can' is a 'Eno' case.
--
isEno :: Can a b -> Bool
isEno :: Can a b -> Bool
isEno (Eno b
_) = Bool
True
isEno Can a b
_ = Bool
False

-- | Detect if a 'Can' is a 'Two' case.
--
isTwo :: Can a b -> Bool
isTwo :: Can a b -> Bool
isTwo (Two a
_ b
_) = Bool
True
isTwo Can a b
_ = Bool
False

-- | Detect if a 'Can' is a 'Non' case.
--
isNon :: Can a b -> Bool
isNon :: Can a b -> Bool
isNon Can a b
Non = Bool
True
isNon Can a b
_ = Bool
False

-- -------------------------------------------------------------------- --
-- Filtering

-- | Given a 'Foldable' of 'Can's, collect the values of the
-- 'One' cases, if any.
--
ones :: Foldable f => f (Can a b) -> [a]
ones :: f (Can a b) -> [a]
ones = (Can a b -> [a] -> [a]) -> [a] -> f (Can a b) -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> [a] -> [a]
forall a b. Can a b -> [a] -> [a]
go []
  where
    go :: Can a b -> [a] -> [a]
go (One a
a) [a]
acc = a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc
    go Can a b
_ [a]
acc = [a]
acc

-- | Given a 'Foldable' of 'Can's, collect the values of the
-- 'Eno' cases, if any.
--
enos :: Foldable f => f (Can a b) -> [b]
enos :: f (Can a b) -> [b]
enos = (Can a b -> [b] -> [b]) -> [b] -> f (Can a b) -> [b]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> [b] -> [b]
forall a a. Can a a -> [a] -> [a]
go []
  where
    go :: Can a a -> [a] -> [a]
go (Eno a
a) [a]
acc = a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc
    go Can a a
_ [a]
acc = [a]
acc

-- | Given a 'Foldable' of 'Can's, collect the values of the
-- 'Two' cases, if any.
--
twos :: Foldable f => f (Can a b) -> [(a,b)]
twos :: f (Can a b) -> [(a, b)]
twos = (Can a b -> [(a, b)] -> [(a, b)])
-> [(a, b)] -> f (Can a b) -> [(a, b)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> [(a, b)] -> [(a, b)]
forall a b. Can a b -> [(a, b)] -> [(a, b)]
go []
  where
    go :: Can a b -> [(a, b)] -> [(a, b)]
go (Two a
a b
b) [(a, b)]
acc = (a
a,b
b)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
acc
    go Can a b
_ [(a, b)]
acc = [(a, b)]
acc

-- | Filter the 'One' cases of a 'Foldable' of 'Can' values.
--
filterOnes :: Foldable f => f (Can a b) -> [Can a b]
filterOnes :: f (Can a b) -> [Can a b]
filterOnes = (Can a b -> [Can a b] -> [Can a b])
-> [Can a b] -> f (Can a b) -> [Can a b]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> [Can a b] -> [Can a b]
forall a b. Can a b -> [Can a b] -> [Can a b]
go []
  where
    go :: Can a b -> [Can a b] -> [Can a b]
go (One a
_) [Can a b]
acc = [Can a b]
acc
    go Can a b
t [Can a b]
acc = Can a b
tCan a b -> [Can a b] -> [Can a b]
forall a. a -> [a] -> [a]
:[Can a b]
acc

-- | Filter the 'Eno' cases of a 'Foldable' of 'Can' values.
--
filterEnos :: Foldable f => f (Can a b) -> [Can a b]
filterEnos :: f (Can a b) -> [Can a b]
filterEnos = (Can a b -> [Can a b] -> [Can a b])
-> [Can a b] -> f (Can a b) -> [Can a b]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> [Can a b] -> [Can a b]
forall a b. Can a b -> [Can a b] -> [Can a b]
go []
  where
    go :: Can a b -> [Can a b] -> [Can a b]
go (Eno b
_) [Can a b]
acc = [Can a b]
acc
    go Can a b
t [Can a b]
acc = Can a b
tCan a b -> [Can a b] -> [Can a b]
forall a. a -> [a] -> [a]
:[Can a b]
acc

-- | Filter the 'Two' cases of a 'Foldable' of 'Can' values.
--
filterTwos :: Foldable f => f (Can a b) -> [Can a b]
filterTwos :: f (Can a b) -> [Can a b]
filterTwos = (Can a b -> [Can a b] -> [Can a b])
-> [Can a b] -> f (Can a b) -> [Can a b]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> [Can a b] -> [Can a b]
forall a b. Can a b -> [Can a b] -> [Can a b]
go []
  where
    go :: Can a b -> [Can a b] -> [Can a b]
go (Two a
_ b
_) [Can a b]
acc = [Can a b]
acc
    go Can a b
t [Can a b]
acc = Can a b
tCan a b -> [Can a b] -> [Can a b]
forall a. a -> [a] -> [a]
:[Can a b]
acc

-- | Filter the 'Non' cases of a 'Foldable' of 'Can' values.
--
filterNons :: Foldable f => f (Can a b) -> [Can a b]
filterNons :: f (Can a b) -> [Can a b]
filterNons = (Can a b -> [Can a b] -> [Can a b])
-> [Can a b] -> f (Can a b) -> [Can a b]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> [Can a b] -> [Can a b]
forall a b. Can a b -> [Can a b] -> [Can a b]
go []
  where
    go :: Can a b -> [Can a b] -> [Can a b]
go Can a b
Non [Can a b]
acc = [Can a b]
acc
    go Can a b
t [Can a b]
acc = Can a b
tCan a b -> [Can a b] -> [Can a b]
forall a. a -> [a] -> [a]
:[Can a b]
acc

-- -------------------------------------------------------------------- --
-- Folding

-- | Fold over the 'One' cases of a 'Foldable' of 'Can's by some
-- accumulating function.
--
foldOnes :: Foldable f => (a -> m -> m) -> m -> f (Can a b) -> m
foldOnes :: (a -> m -> m) -> m -> f (Can a b) -> m
foldOnes a -> m -> m
k = (Can a b -> m -> m) -> m -> f (Can a b) -> m
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> m -> m
forall b. Can a b -> m -> m
go
  where
    go :: Can a b -> m -> m
go (One a
a) m
acc = a -> m -> m
k a
a m
acc
    go Can a b
_ m
acc = m
acc

-- | Fold over the 'Eno' cases of a 'Foldable' of 'Can's by some
-- accumulating function.
--
foldEnos :: Foldable f => (b -> m -> m) -> m -> f (Can a b) -> m
foldEnos :: (b -> m -> m) -> m -> f (Can a b) -> m
foldEnos b -> m -> m
k = (Can a b -> m -> m) -> m -> f (Can a b) -> m
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> m -> m
forall a. Can a b -> m -> m
go
  where
    go :: Can a b -> m -> m
go (Eno b
b) m
acc = b -> m -> m
k b
b m
acc
    go Can a b
_ m
acc = m
acc

-- | Fold over the 'Two' cases of a 'Foldable' of 'Can's by some
-- accumulating function.
--
foldTwos :: Foldable f => (a -> b -> m -> m) -> m -> f (Can a b) -> m
foldTwos :: (a -> b -> m -> m) -> m -> f (Can a b) -> m
foldTwos a -> b -> m -> m
k = (Can a b -> m -> m) -> m -> f (Can a b) -> m
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> m -> m
go
  where
    go :: Can a b -> m -> m
go (Two a
a b
b) m
acc = a -> b -> m -> m
k a
a b
b m
acc
    go Can a b
_ m
acc = m
acc

-- | Gather a 'Can' of two lists and produce a list of 'Can' values,
-- mapping the 'Non' case to the empty list, One' case to a list
-- of 'One's, the 'Eno' case to a list of 'Eno's, or zipping 'Two'
-- along both lists.
--
gatherCans :: Can [a] [b] -> [Can a b]
gatherCans :: Can [a] [b] -> [Can a b]
gatherCans Can [a] [b]
Non = []
gatherCans (One [a]
as) = (a -> Can a b) -> [a] -> [Can a b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Can a b
forall a b. a -> Can a b
One [a]
as
gatherCans (Eno [b]
bs) = (b -> Can a b) -> [b] -> [Can a b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Can a b
forall a b. b -> Can a b
Eno [b]
bs
gatherCans (Two [a]
as [b]
bs) = (a -> b -> Can a b) -> [a] -> [b] -> [Can a b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> Can a b
forall a b. a -> b -> Can a b
Two [a]
as [b]
bs

-- -------------------------------------------------------------------- --
-- Partitioning

-- | Partition a list of 'Can' values into a triple of lists of
-- all of their constituent parts
--
partitionAll :: Foldable f => f (Can a b) -> ([a], [b], [(a,b)])
partitionAll :: f (Can a b) -> ([a], [b], [(a, b)])
partitionAll = ((Can a b -> ([a], [b], [(a, b)]) -> ([a], [b], [(a, b)]))
 -> ([a], [b], [(a, b)]) -> f (Can a b) -> ([a], [b], [(a, b)]))
-> ([a], [b], [(a, b)])
-> (Can a b -> ([a], [b], [(a, b)]) -> ([a], [b], [(a, b)]))
-> f (Can a b)
-> ([a], [b], [(a, b)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Can a b -> ([a], [b], [(a, b)]) -> ([a], [b], [(a, b)]))
-> ([a], [b], [(a, b)]) -> f (Can a b) -> ([a], [b], [(a, b)])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([a], [b], [(a, b)])
forall a. Monoid a => a
mempty ((Can a b -> ([a], [b], [(a, b)]) -> ([a], [b], [(a, b)]))
 -> f (Can a b) -> ([a], [b], [(a, b)]))
-> (Can a b -> ([a], [b], [(a, b)]) -> ([a], [b], [(a, b)]))
-> f (Can a b)
-> ([a], [b], [(a, b)])
forall a b. (a -> b) -> a -> b
$ \Can a b
aa ~([a]
as, [b]
bs, [(a, b)]
cs) -> case Can a b
aa of
    Can a b
Non -> ([a]
as, [b]
bs, [(a, b)]
cs)
    One a
a -> (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as, [b]
bs, [(a, b)]
cs)
    Eno b
b -> ([a]
as, b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
bs, [(a, b)]
cs)
    Two a
a b
b -> ([a]
as, [b]
bs, (a
a,b
b)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
cs)

-- | Partition a list of 'Either' values, separating them into
-- a 'Can' value of lists of left and right values, or 'Non' in the
-- case of an empty list.
--
partitionEithers :: Foldable f => f (Either a b) -> Can [a] [b]
partitionEithers :: f (Either a b) -> Can [a] [b]
partitionEithers = ([a], [b]) -> Can [a] [b]
forall a a. ([a], [a]) -> Can [a] [a]
go (([a], [b]) -> Can [a] [b])
-> (f (Either a b) -> ([a], [b])) -> f (Either a b) -> Can [a] [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either a b] -> ([a], [b])
forall a b. [Either a b] -> ([a], [b])
E.partitionEithers ([Either a b] -> ([a], [b]))
-> (f (Either a b) -> [Either a b]) -> f (Either a b) -> ([a], [b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Either a b) -> [Either a b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where
    go :: ([a], [a]) -> Can [a] [a]
go ([], []) = Can [a] [a]
forall a b. Can a b
Non
    go ([a]
ls, []) = [a] -> Can [a] [a]
forall a b. a -> Can a b
One [a]
ls
    go ([], [a]
rs) = [a] -> Can [a] [a]
forall a b. b -> Can a b
Eno [a]
rs
    go ([a]
ls, [a]
rs) = [a] -> [a] -> Can [a] [a]
forall a b. a -> b -> Can a b
Two [a]
ls [a]
rs

-- | Given a 'Foldable' of 'Can's, partition it into a tuple of alternatives
-- their parts.
--
partitionCans
    :: forall f t a b
    . ( Foldable t
      , Alternative f
      )
    => t (Can a b) -> (f a, f b)
partitionCans :: t (Can a b) -> (f a, f b)
partitionCans = (Can a b -> (f a, f b) -> (f a, f b))
-> (f a, f b) -> t (Can a b) -> (f a, f b)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Can a b -> (f a, f b) -> (f a, f b)
forall (f :: * -> *) (f :: * -> *) a a.
(Alternative f, Alternative f) =>
Can a a -> (f a, f a) -> (f a, f a)
go (f a
forall (f :: * -> *) a. Alternative f => f a
empty, f b
forall (f :: * -> *) a. Alternative f => f a
empty)
  where
    go :: Can a a -> (f a, f a) -> (f a, f a)
go Can a a
Non (f a, f a)
acc = (f a, f a)
acc
    go (One a
a) (f a
as, f a
bs) = (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
as, f a
bs)
    go (Eno a
b) (f a
as, f a
bs) = (f a
as, a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
bs)
    go (Two a
a a
b) (f a
as, f a
bs) = (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
as, a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
bs)

-- | Partition a structure by mapping its contents into 'Can's,
-- and folding over '(<|>)'.
--
mapCans
    :: forall f t a b c
    . ( Alternative f
      , Traversable t
      )
    => (a -> Can b c)
    -> t a
    -> (f b, f c)
mapCans :: (a -> Can b c) -> t a -> (f b, f c)
mapCans a -> Can b c
f = t (Can b c) -> (f b, f c)
forall (f :: * -> *) (t :: * -> *) a b.
(Foldable t, Alternative f) =>
t (Can a b) -> (f a, f b)
partitionCans (t (Can b c) -> (f b, f c))
-> (t a -> t (Can b c)) -> t a -> (f b, f c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Can b c) -> t a -> t (Can b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Can b c
f

-- -------------------------------------------------------------------- --
-- Distributivity

-- | Distribute a 'Can' value over a product.
--
distributeCan :: Can (a,b) c -> (Can a c, Can b c)
distributeCan :: Can (a, b) c -> (Can a c, Can b c)
distributeCan = \case
    Can (a, b) c
Non -> (Can a c
forall a b. Can a b
Non, Can b c
forall a b. Can a b
Non)
    One (a
a,b
b) -> (a -> Can a c
forall a b. a -> Can a b
One a
a, b -> Can b c
forall a b. a -> Can a b
One b
b)
    Eno c
c -> (c -> Can a c
forall a b. b -> Can a b
Eno c
c, c -> Can b c
forall a b. b -> Can a b
Eno c
c)
    Two (a
a,b
b) c
c -> (a -> c -> Can a c
forall a b. a -> b -> Can a b
Two a
a c
c, b -> c -> Can b c
forall a b. a -> b -> Can a b
Two b
b c
c)

-- | Codistribute a coproduct over a 'Can' value.
--
codistributeCan :: Either (Can a c) (Can b c) -> Can (Either a b) c
codistributeCan :: Either (Can a c) (Can b c) -> Can (Either a b) c
codistributeCan = \case
    Left Can a c
ac -> case Can a c
ac of
      Can a c
Non -> Can (Either a b) c
forall a b. Can a b
Non
      One a
a -> Either a b -> Can (Either a b) c
forall a b. a -> Can a b
One (a -> Either a b
forall a b. a -> Either a b
Left a
a)
      Eno c
c -> c -> Can (Either a b) c
forall a b. b -> Can a b
Eno c
c
      Two a
a c
c -> Either a b -> c -> Can (Either a b) c
forall a b. a -> b -> Can a b
Two (a -> Either a b
forall a b. a -> Either a b
Left a
a) c
c
    Right Can b c
bc -> case Can b c
bc of
      Can b c
Non -> Can (Either a b) c
forall a b. Can a b
Non
      One b
b -> Either a b -> Can (Either a b) c
forall a b. a -> Can a b
One (b -> Either a b
forall a b. b -> Either a b
Right b
b)
      Eno c
c -> c -> Can (Either a b) c
forall a b. b -> Can a b
Eno c
c
      Two b
b c
c -> Either a b -> c -> Can (Either a b) c
forall a b. a -> b -> Can a b
Two (b -> Either a b
forall a b. b -> Either a b
Right b
b) c
c

-- -------------------------------------------------------------------- --
-- Associativity

-- | Re-associate a 'Can' of cans from left to right.
--
reassocLR :: Can (Can a b) c -> Can a (Can b c)
reassocLR :: Can (Can a b) c -> Can a (Can b c)
reassocLR = \case
    Can (Can a b) c
Non -> Can a (Can b c)
forall a b. Can a b
Non
    One Can a b
c -> case Can a b
c of
      Can a b
Non -> Can b c -> Can a (Can b c)
forall a b. b -> Can a b
Eno Can b c
forall a b. Can a b
Non
      One a
a -> a -> Can a (Can b c)
forall a b. a -> Can a b
One a
a
      Eno b
b -> Can b c -> Can a (Can b c)
forall a b. b -> Can a b
Eno (b -> Can b c
forall a b. a -> Can a b
One b
b)
      Two a
a b
b -> a -> Can b c -> Can a (Can b c)
forall a b. a -> b -> Can a b
Two a
a (b -> Can b c
forall a b. a -> Can a b
One b
b)
    Eno c
c -> Can b c -> Can a (Can b c)
forall a b. b -> Can a b
Eno (c -> Can b c
forall a b. b -> Can a b
Eno c
c)
    Two Can a b
c c
d -> case Can a b
c of
      Can a b
Non -> Can b c -> Can a (Can b c)
forall a b. b -> Can a b
Eno (c -> Can b c
forall a b. b -> Can a b
Eno c
d)
      One a
a -> a -> Can b c -> Can a (Can b c)
forall a b. a -> b -> Can a b
Two a
a (c -> Can b c
forall a b. b -> Can a b
Eno c
d)
      Eno b
b -> Can b c -> Can a (Can b c)
forall a b. b -> Can a b
Eno (b -> c -> Can b c
forall a b. a -> b -> Can a b
Two b
b c
d)
      Two a
a b
b -> a -> Can b c -> Can a (Can b c)
forall a b. a -> b -> Can a b
Two a
a (b -> c -> Can b c
forall a b. a -> b -> Can a b
Two b
b c
d)

-- | Re-associate a 'Can' of cans from right to left.
--
reassocRL :: Can a (Can b c) -> Can (Can a b) c
reassocRL :: Can a (Can b c) -> Can (Can a b) c
reassocRL = \case
    Can a (Can b c)
Non -> Can (Can a b) c
forall a b. Can a b
Non
    One a
a -> Can a b -> Can (Can a b) c
forall a b. a -> Can a b
One (a -> Can a b
forall a b. a -> Can a b
One a
a)
    Eno Can b c
c -> case Can b c
c of
      Can b c
Non -> Can a b -> Can (Can a b) c
forall a b. a -> Can a b
One Can a b
forall a b. Can a b
Non
      One b
b -> Can a b -> Can (Can a b) c
forall a b. a -> Can a b
One (b -> Can a b
forall a b. b -> Can a b
Eno b
b)
      Eno c
d -> c -> Can (Can a b) c
forall a b. b -> Can a b
Eno c
d
      Two b
b c
d -> Can a b -> c -> Can (Can a b) c
forall a b. a -> b -> Can a b
Two (b -> Can a b
forall a b. b -> Can a b
Eno b
b) c
d
    Two a
a Can b c
c -> case Can b c
c of
      Can b c
Non -> Can a b -> Can (Can a b) c
forall a b. a -> Can a b
One (a -> Can a b
forall a b. a -> Can a b
One a
a)
      One b
b -> Can a b -> Can (Can a b) c
forall a b. a -> Can a b
One (a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b)
      Eno c
d -> Can a b -> c -> Can (Can a b) c
forall a b. a -> b -> Can a b
Two (a -> Can a b
forall a b. a -> Can a b
One a
a) c
d
      Two b
b c
d -> Can a b -> c -> Can (Can a b) c
forall a b. a -> b -> Can a b
Two (a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b) c
d

-- -------------------------------------------------------------------- --
-- Symmetry

-- | Swap the positions of values in a 'Can'.
--
swapCan :: Can a b -> Can b a
swapCan :: Can a b -> Can b a
swapCan = \case
    Can a b
Non -> Can b a
forall a b. Can a b
Non
    One a
a -> a -> Can b a
forall a b. b -> Can a b
Eno a
a
    Eno b
b -> b -> Can b a
forall a b. a -> Can a b
One b
b
    Two a
a b
b -> b -> a -> Can b a
forall a b. a -> b -> Can a b
Two b
b a
a

-- -------------------------------------------------------------------- --
-- Curry & Uncurry

-- | Curry a function from a 'Can' to a 'Maybe' value, resulting in a
-- function of curried 'Maybe' values. This is analogous to currying
-- for '(->)'.
--
canCurry :: (Can a b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
canCurry :: (Can a b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
canCurry Can a b -> Maybe c
k Maybe a
ma Maybe b
mb = case (Maybe a
ma, Maybe b
mb) of
    (Maybe a
Nothing, Maybe b
Nothing) -> Can a b -> Maybe c
k Can a b
forall a b. Can a b
Non
    (Just a
a, Maybe b
Nothing) -> Can a b -> Maybe c
k (a -> Can a b
forall a b. a -> Can a b
One a
a)
    (Maybe a
Nothing, Just b
b) -> Can a b -> Maybe c
k (b -> Can a b
forall a b. b -> Can a b
Eno b
b)
    (Just a
a, Just b
b) -> Can a b -> Maybe c
k (a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b)

-- | "Uncurry" a function from a 'Can' to a 'Maybe' value, resulting in a
-- function of curried 'Maybe' values. This is analogous to uncurrying
-- for '(->)'.
--
canUncurry :: (Maybe a -> Maybe b -> Maybe c) -> Can a b -> Maybe c
canUncurry :: (Maybe a -> Maybe b -> Maybe c) -> Can a b -> Maybe c
canUncurry Maybe a -> Maybe b -> Maybe c
k = \case
    Can a b
Non -> Maybe a -> Maybe b -> Maybe c
k Maybe a
forall a. Maybe a
Nothing Maybe b
forall a. Maybe a
Nothing
    One a
a -> Maybe a -> Maybe b -> Maybe c
k (a -> Maybe a
forall a. a -> Maybe a
Just a
a) Maybe b
forall a. Maybe a
Nothing
    Eno b
b -> Maybe a -> Maybe b -> Maybe c
k Maybe a
forall a. Maybe a
Nothing (b -> Maybe b
forall a. a -> Maybe a
Just b
b)
    Two a
a b
b -> Maybe a -> Maybe b -> Maybe c
k (a -> Maybe a
forall a. a -> Maybe a
Just a
a) (b -> Maybe b
forall a. a -> Maybe a
Just b
b)

-- -------------------------------------------------------------------- --
-- Std instances


instance (Hashable a, Hashable b) => Hashable (Can a b)

instance Functor (Can a) where
  fmap :: (a -> b) -> Can a a -> Can a b
fmap a -> b
_ Can a a
Non = Can a b
forall a b. Can a b
Non
  fmap a -> b
_ (One a
a) = a -> Can a b
forall a b. a -> Can a b
One a
a
  fmap a -> b
f (Eno a
b) = b -> Can a b
forall a b. b -> Can a b
Eno (a -> b
f a
b)
  fmap a -> b
f (Two a
a a
b) = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a (a -> b
f a
b)

instance Foldable (Can a) where
  foldMap :: (a -> m) -> Can a a -> m
foldMap a -> m
k (Eno a
b) = a -> m
k a
b
  foldMap a -> m
k (Two a
_ a
b) = a -> m
k a
b
  foldMap a -> m
_ Can a a
_ = m
forall a. Monoid a => a
mempty

instance Traversable (Can a) where
  traverse :: (a -> f b) -> Can a a -> f (Can a b)
traverse a -> f b
k = \case
    Can a a
Non -> Can a b -> f (Can a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Can a b
forall a b. Can a b
Non
    One a
a -> Can a b -> f (Can a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Can a b
forall a b. a -> Can a b
One a
a)
    Eno a
b -> b -> Can a b
forall a b. b -> Can a b
Eno (b -> Can a b) -> f b -> f (Can a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
k a
b
    Two a
a a
b -> a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a (b -> Can a b) -> f b -> f (Can a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
k a
b

instance Semigroup a => Applicative (Can a) where
  pure :: a -> Can a a
pure = a -> Can a a
forall a b. b -> Can a b
Eno

  Can a (a -> b)
_ <*> :: Can a (a -> b) -> Can a a -> Can a b
<*> Can a a
Non = Can a b
forall a b. Can a b
Non
  Can a (a -> b)
Non <*> Can a a
_ = Can a b
forall a b. Can a b
Non
  One a
a <*> Can a a
_ = a -> Can a b
forall a b. a -> Can a b
One a
a
  Eno a -> b
_ <*> One a
b = a -> Can a b
forall a b. a -> Can a b
One a
b
  Eno a -> b
f <*> Eno a
a = b -> Can a b
forall a b. b -> Can a b
Eno (a -> b
f a
a)
  Eno a -> b
f <*> Two a
a a
b = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a (a -> b
f a
b)
  Two a
a a -> b
_ <*> One a
b = a -> Can a b
forall a b. a -> Can a b
One (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b)
  Two a
a a -> b
f <*> Eno a
b = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a (a -> b
f a
b)
  Two a
a a -> b
f <*> Two a
b a
c = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b) (a -> b
f a
c)

instance Semigroup a => Monad (Can a) where
  return :: a -> Can a a
return = a -> Can a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >> :: Can a a -> Can a b -> Can a b
(>>) = Can a a -> Can a b -> Can a b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

  Can a a
Non >>= :: Can a a -> (a -> Can a b) -> Can a b
>>= a -> Can a b
_ = Can a b
forall a b. Can a b
Non
  One a
a >>= a -> Can a b
_ = a -> Can a b
forall a b. a -> Can a b
One a
a
  Eno a
b >>= a -> Can a b
k = a -> Can a b
k a
b
  Two a
a a
b >>= a -> Can a b
k = case a -> Can a b
k a
b of
    Can a b
Non -> Can a b
forall a b. Can a b
Non
    One a
c -> a -> Can a b
forall a b. a -> Can a b
One (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c)
    Eno b
c -> b -> Can a b
forall a b. b -> Can a b
Eno b
c
    Two a
c b
d -> a -> b -> Can a b
forall a b. a -> b -> Can a b
Two (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c) b
d

instance (Semigroup a, Semigroup b) => Semigroup (Can a b) where
  Can a b
Non <> :: Can a b -> Can a b -> Can a b
<> Can a b
b = Can a b
b
  Can a b
b <> Can a b
Non = Can a b
b
  One a
a <> One a
b = a -> Can a b
forall a b. a -> Can a b
One (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b)
  One a
a <> Eno b
b = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b
  One a
a <> Two a
b b
c = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b) b
c
  Eno b
a <> Eno b
b = b -> Can a b
forall a b. b -> Can a b
Eno (b
a b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
b)
  Eno b
b <> One a
a = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b
  Eno b
b <> Two a
a b
c = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a (b
b b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
c)
  Two a
a b
b <> Two a
c b
d = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c) (b
b b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
d)
  Two a
a b
b <> One a
c = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c) b
b
  Two a
a b
b <> Eno b
c = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a (b
b b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
c)


instance (Semigroup a, Semigroup b) => Monoid (Can a b) where
  mempty :: Can a b
mempty = Can a b
forall a b. Can a b
Non
  mappend :: Can a b -> Can a b -> Can a b
mappend = Can a b -> Can a b -> Can a b
forall a. Semigroup a => a -> a -> a
(<>)

instance (NFData a, NFData b) => NFData (Can a b) where
    rnf :: Can a b -> ()
rnf Can a b
Non = ()
    rnf (One a
a) = a -> ()
forall a. NFData a => a -> ()
rnf a
a
    rnf (Eno b
b) = b -> ()
forall a. NFData a => a -> ()
rnf b
b
    rnf (Two a
a b
b) = a -> ()
forall a. NFData a => a -> ()
rnf a
a () -> () -> ()
`seq` b -> ()
forall a. NFData a => a -> ()
rnf b
b

instance (Binary a, Binary b) => Binary (Can a b) where
  put :: Can a b -> Put
put Can a b
Non = Int -> Put
forall t. Binary t => t -> Put
put @Int Int
0
  put (One a
a) = Int -> Put
forall t. Binary t => t -> Put
put @Int Int
1 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Put
forall t. Binary t => t -> Put
put a
a
  put (Eno b
b) = Int -> Put
forall t. Binary t => t -> Put
put @Int Int
2 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Put
forall t. Binary t => t -> Put
put b
b
  put (Two a
a b
b) = Int -> Put
forall t. Binary t => t -> Put
put @Int Int
3 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Put
forall t. Binary t => t -> Put
put a
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Put
forall t. Binary t => t -> Put
put b
b

  get :: Get (Can a b)
get = Binary Int => Get Int
forall t. Binary t => Get t
get @Int Get Int -> (Int -> Get (Can a b)) -> Get (Can a b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Int
0 -> Can a b -> Get (Can a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Can a b
forall a b. Can a b
Non
    Int
1 -> a -> Can a b
forall a b. a -> Can a b
One (a -> Can a b) -> Get a -> Get (Can a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
forall t. Binary t => Get t
get
    Int
2 -> b -> Can a b
forall a b. b -> Can a b
Eno (b -> Can a b) -> Get b -> Get (Can a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get b
forall t. Binary t => Get t
get
    Int
3 -> a -> b -> Can a b
forall a b. a -> b -> Can a b
Two (a -> b -> Can a b) -> Get a -> Get (b -> Can a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
forall t. Binary t => Get t
get Get (b -> Can a b) -> Get b -> Get (Can a b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get b
forall t. Binary t => Get t
get
    Int
_ -> String -> Get (Can a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid Can index"

-- -------------------------------------------------------------------- --
-- Bifunctors

instance Bifunctor Can where
  bimap :: (a -> b) -> (c -> d) -> Can a c -> Can b d
bimap a -> b
f c -> d
g = \case
    Can a c
Non -> Can b d
forall a b. Can a b
Non
    One a
a -> b -> Can b d
forall a b. a -> Can a b
One (a -> b
f a
a)
    Eno c
b -> d -> Can b d
forall a b. b -> Can a b
Eno (c -> d
g c
b)
    Two a
a c
b -> b -> d -> Can b d
forall a b. a -> b -> Can a b
Two (a -> b
f a
a) (c -> d
g c
b)

instance Bifoldable Can where
  bifoldMap :: (a -> m) -> (b -> m) -> Can a b -> m
bifoldMap a -> m
f b -> m
g = \case
    Can a b
Non -> m
forall a. Monoid a => a
mempty
    One a
a -> a -> m
f a
a
    Eno b
b -> b -> m
g b
b
    Two a
a b
b -> a -> m
f a
a m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` b -> m
g b
b

instance Bitraversable Can where
  bitraverse :: (a -> f c) -> (b -> f d) -> Can a b -> f (Can c d)
bitraverse a -> f c
f b -> f d
g = \case
    Can a b
Non -> Can c d -> f (Can c d)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Can c d
forall a b. Can a b
Non
    One a
a -> c -> Can c d
forall a b. a -> Can a b
One (c -> Can c d) -> f c -> f (Can c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
a
    Eno b
b -> d -> Can c d
forall a b. b -> Can a b
Eno (d -> Can c d) -> f d -> f (Can c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f d
g b
b
    Two a
a b
b -> c -> d -> Can c d
forall a b. a -> b -> Can a b
Two (c -> d -> Can c d) -> f c -> f (d -> Can c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
a f (d -> Can c d) -> f d -> f (Can c d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> f d
g b
b