{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE Safe #-}
-- |
-- Module       : Data.Can
-- Copyright    : (c) 2020-2021 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(..)
  -- ** Type synonyms
, type (⊗)
  -- * Combinators
, canFst
, canSnd
, isOne
, isEno
, isTwo
, isNon
  -- ** Eliminators
, can
, canWithMerge
, canEach
, canEachA
  -- * Folding and Unfolding
, foldOnes
, foldEnos
, foldTwos
, gatherCans
, unfoldr
, unfoldrM
, iterateUntil
, iterateUntilM
, accumUntil
, accumUntilM
  -- * Filtering
, ones
, enos
, twos
, filterOnes
, filterEnos
, filterTwos
, filterNons
  -- * Curry & Uncurry
, canCurry
, canUncurry
  -- * Partitioning
, partitionCans
, partitionAll
, partitionEithers
, mapCans
, eqCan
  -- * Distributivity
, distributeCan
, codistributeCan
  -- * Associativity
, reassocLR
, reassocRL
  -- * Symmetry
, swapCan
) where


import Control.Applicative (Alternative(..), liftA2)
import Control.DeepSeq
import Control.Monad.Zip
import Control.Monad

import Data.Biapplicative
import Data.Bifoldable
import Data.Binary (Binary(..))
import Data.Bitraversable
import Data.Data
import qualified Data.Either as E
import Data.Functor.Classes
import Data.Functor.Contravariant (Equivalence(..))
import Data.Foldable
import Data.Functor.Identity
import Data.Hashable
import Data.Hashable.Lifted

import GHC.Generics
import GHC.Read

import qualified Language.Haskell.TH.Syntax as TH

import Data.Smash.Internal

import Text.Read hiding (get)




{- $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' ('These' 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
    , Can a b -> Q Exp
Can a b -> Q (TExp (Can a b))
(Can a b -> Q Exp)
-> (Can a b -> Q (TExp (Can a b))) -> Lift (Can a b)
forall a b. (Lift a, Lift b) => Can a b -> Q Exp
forall a b. (Lift a, Lift b) => Can a b -> Q (TExp (Can a b))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Can a b -> Q (TExp (Can a b))
$cliftTyped :: forall a b. (Lift a, Lift b) => Can a b -> Q (TExp (Can a b))
lift :: Can a b -> Q Exp
$clift :: forall a b. (Lift a, Lift b) => Can a b -> Q Exp
TH.Lift
    )

-- | A type operator synonym for 'Can'
--
type a ⊗ b = Can a b

-- -------------------------------------------------------------------- --
-- 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

-- | Case elimination for the 'Can' datatype, with uniform behaviour.
--
canWithMerge
    :: c
      -- ^ default value to supply for the 'Non' case
    -> (a -> c)
      -- ^ eliminator for the 'One' case
    -> (b -> c)
      -- ^ eliminator for the 'Eno' case
    -> (c -> c -> c)
      -- ^ merger for the 'Two' case
    -> Can a b
    -> c
canWithMerge :: c -> (a -> c) -> (b -> c) -> (c -> c -> c) -> Can a b -> c
canWithMerge c
c a -> c
_ b -> c
_ c -> c -> c
_ Can a b
Non = c
c
canWithMerge c
_ a -> c
f b -> c
_ c -> c -> c
_ (One a
a) = a -> c
f a
a
canWithMerge c
_ a -> c
_ b -> c
g c -> c -> c
_ (Eno b
b) = b -> c
g b
b
canWithMerge c
_ a -> c
f b -> c
g c -> c -> c
m (Two a
a b
b) = c -> c -> c
m (a -> c
f a
a) (b -> c
g b
b)

-- | Case elimination for the 'Can' datatype, with uniform behaviour over a
-- 'Monoid' result.
--
canEach
    :: Monoid c
    => (a -> c)
      -- ^ eliminator for the 'One' case
    -> (b -> c)
      -- ^ eliminator for the 'Eno' case
    -> Can a b
    -> c
canEach :: (a -> c) -> (b -> c) -> Can a b -> c
canEach a -> c
f b -> c
g = c -> (a -> c) -> (b -> c) -> (c -> c -> c) -> Can a b -> c
forall c a b.
c -> (a -> c) -> (b -> c) -> (c -> c -> c) -> Can a b -> c
canWithMerge c
forall a. Monoid a => a
mempty a -> c
f b -> c
g c -> c -> c
forall a. Semigroup a => a -> a -> a
(<>)

-- | Case elimination for the 'Can' datatype, with uniform behaviour over a
-- 'Monoid' result in the context of an 'Applicative'.
--
canEachA
    :: Applicative m
    => Monoid c
    => (a -> m c)
      -- ^ eliminator for the 'One' case
    -> (b -> m c)
      -- ^ eliminator for the 'Eno' case
    -> Can a b
    -> m c
canEachA :: (a -> m c) -> (b -> m c) -> Can a b -> m c
canEachA a -> m c
f b -> m c
g = m c
-> (a -> m c)
-> (b -> m c)
-> (m c -> m c -> m c)
-> Can a b
-> m c
forall c a b.
c -> (a -> c) -> (b -> c) -> (c -> c -> c) -> Can a b -> c
canWithMerge (c -> m c
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
forall a. Monoid a => a
mempty) a -> m c
f b -> m c
g ((c -> c -> c) -> m c -> m c -> m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 c -> c -> c
forall a. Semigroup a => a -> a -> a
(<>))

-- -------------------------------------------------------------------- --
-- 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

-- | Unfold from right to left into a pointed product. For a variant
-- that accumulates in the seed instead of just updating with a
-- new value, see 'accumUntil' and 'accumUntilM'.
--
unfoldr :: Alternative f => (b -> Can a b) -> b -> f a
unfoldr :: (b -> Can a b) -> b -> f a
unfoldr b -> Can a b
f = Identity (f a) -> f a
forall a. Identity a -> a
runIdentity (Identity (f a) -> f a) -> (b -> Identity (f a)) -> b -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Identity (Can a b)) -> b -> Identity (f a)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Alternative f) =>
(b -> m (Can a b)) -> b -> m (f a)
unfoldrM (Can a b -> Identity (Can a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Can a b -> Identity (Can a b))
-> (b -> Can a b) -> b -> Identity (Can a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Can a b
f)

-- | Unfold from right to left into a monadic computation over a pointed product
--
unfoldrM :: (Monad m, Alternative f) => (b -> m (Can a b)) -> b -> m (f a)
unfoldrM :: (b -> m (Can a b)) -> b -> m (f a)
unfoldrM b -> m (Can a b)
f b
b = b -> m (Can a b)
f b
b m (Can a b) -> (Can a b -> m (f a)) -> m (f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Can a b
Non -> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
forall (f :: * -> *) a. Alternative f => f a
empty
    One a
a -> (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 -> f a) -> m (f a) -> m (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b -> m (Can a b)) -> b -> m (f a)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Alternative f) =>
(b -> m (Can a b)) -> b -> m (f a)
unfoldrM b -> m (Can a b)
f b
b
    Eno b
b' -> (b -> m (Can a b)) -> b -> m (f a)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Alternative f) =>
(b -> m (Can a b)) -> b -> m (f a)
unfoldrM b -> m (Can a b)
f b
b'
    Two a
a b
b' -> (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 -> f a) -> m (f a) -> m (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b -> m (Can a b)) -> b -> m (f a)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Alternative f) =>
(b -> m (Can a b)) -> b -> m (f a)
unfoldrM b -> m (Can a b)
f b
b'

-- | Iterate on a seed, accumulating a result. See 'iterateUntilM' for
-- more details.
--
iterateUntil :: Alternative f => (b -> Can a b) -> b -> f a
iterateUntil :: (b -> Can a b) -> b -> f a
iterateUntil b -> Can a b
f = Identity (f a) -> f a
forall a. Identity a -> a
runIdentity (Identity (f a) -> f a) -> (b -> Identity (f a)) -> b -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Identity (Can a b)) -> b -> Identity (f a)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Alternative f) =>
(b -> m (Can a b)) -> b -> m (f a)
iterateUntilM (Can a b -> Identity (Can a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Can a b -> Identity (Can a b))
-> (b -> Can a b) -> b -> Identity (Can a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Can a b
f)

-- | Iterate on a seed, which may result in one of four scenarios:
--
--   1. The function yields a @Non@ value, which terminates the
--      iteration.
--
--   2. The function yields a @One@ value.
--
--   3. The function yields a @Eno@ value, which changes the seed
--      and iteration continues with the new seed.
--
--   4. The function yields the @a@ value of a @Two@ case.
--
iterateUntilM
    :: Monad m
    => Alternative f
    => (b -> m (Can a b))
    -> b
    -> m (f a)
iterateUntilM :: (b -> m (Can a b)) -> b -> m (f a)
iterateUntilM b -> m (Can a b)
f b
b = b -> m (Can a b)
f b
b m (Can a b) -> (Can a b -> m (f a)) -> m (f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Can a b
Non -> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
forall (f :: * -> *) a. Alternative f => f a
empty
    One a
a -> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
    Eno b
b' -> (b -> m (Can a b)) -> b -> m (f a)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Alternative f) =>
(b -> m (Can a b)) -> b -> m (f a)
iterateUntilM b -> m (Can a b)
f b
b'
    Two a
a b
_ -> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)

-- | Iterate on a seed, accumulating values and monoidally
-- updating the seed with each update.
--
accumUntil
    :: Alternative f
    => Monoid b
    => (b -> Can a b)
    -> f a
accumUntil :: (b -> Can a b) -> f a
accumUntil b -> Can a b
f = Identity (f a) -> f a
forall a. Identity a -> a
runIdentity ((b -> Identity (Can a b)) -> Identity (f a)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Alternative f, Monoid b) =>
(b -> m (Can a b)) -> m (f a)
accumUntilM (Can a b -> Identity (Can a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Can a b -> Identity (Can a b))
-> (b -> Can a b) -> b -> Identity (Can a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Can a b
f))

-- | Iterate on a seed, accumulating values and monoidally
-- updating a seed within a monad.
--
accumUntilM
    :: Monad m
    => Alternative f
    => Monoid b
    => (b -> m (Can a b))
    -> m (f a)
accumUntilM :: (b -> m (Can a b)) -> m (f a)
accumUntilM b -> m (Can a b)
f = b -> m (f a)
forall (f :: * -> *). Alternative f => b -> m (f a)
go b
forall a. Monoid a => a
mempty
  where
    go :: b -> m (f a)
go b
b = b -> m (Can a b)
f b
b m (Can a b) -> (Can a b -> m (f a)) -> m (f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Can a b
Non -> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
forall (f :: * -> *) a. Alternative f => f a
empty
      One a
a -> (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 -> f a) -> m (f a) -> m (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> m (f a)
go b
b
      Eno b
b' -> b -> m (f a)
go (b
b' b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
b)
      Two a
a b
b' -> (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 -> f a) -> m (f a) -> m (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> m (f a)
go (b
b' b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
b)

-- -------------------------------------------------------------------- --
-- 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
    :: Alternative f
    => Foldable t
    => 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
    :: Traversable t
    => Alternative f
    => (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.
(Alternative f, Foldable t) =>
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

-- | Equivalence relation formed by grouping of equal 'Can' constructors.
--
eqCan :: Equivalence (Can a b)
eqCan :: Equivalence (Can a b)
eqCan = (Can a b -> Can a b -> Bool) -> Equivalence (Can a b)
forall a. (a -> a -> Bool) -> Equivalence a
Equivalence Can a b -> Can a b -> Bool
forall a b. Can a b -> Can a b -> Bool
equivalence
  where
    equivalence :: Can a b -> Can a b -> Bool
    equivalence :: Can a b -> Can a b -> Bool
equivalence Can a b
Non       Can a b
Non       = Bool
True
    equivalence (One   a
_) (One   a
_) = Bool
True
    equivalence (Eno   b
_) (Eno   b
_) = Bool
True
    equivalence (Two a
_ b
_) (Two a
_ b
_) = Bool
True
    equivalence Can a b
_         Can a b
_         = Bool
False

-- -------------------------------------------------------------------- --
-- 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 = Can (a, b) c -> (Can a c, Can b c)
forall (f :: * -> * -> *) a b c.
Bifunctor f =>
f (a, b) c -> (f a c, f b c)
unzipFirst

-- | 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 = Either (Can a c) (Can b c) -> Can (Either a b) c
forall (f :: * -> * -> *) a c b.
Bifunctor f =>
Either (f a c) (f b c) -> f (Either a b) c
undecideFirst

-- -------------------------------------------------------------------- --
-- 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 = Can b a
-> (a -> Can b a)
-> (b -> Can b a)
-> (a -> b -> Can b a)
-> Can a b
-> Can b a
forall c a b.
c -> (a -> c) -> (b -> c) -> (a -> b -> c) -> Can a b -> c
can Can b a
forall a b. Can a b
Non a -> Can b a
forall a b. b -> Can a b
Eno b -> Can b a
forall a b. a -> Can a b
One ((b -> a -> Can b a) -> a -> b -> Can b a
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> Can b a
forall a b. a -> b -> Can a b
Two)

-- -------------------------------------------------------------------- --
-- 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)

-- -------------------------------------------------------------------- --
-- Functor class instances

instance Eq a => Eq1 (Can a) where
  liftEq :: (a -> b -> Bool) -> Can a a -> Can a b -> Bool
liftEq = (a -> a -> Bool) -> (a -> b -> Bool) -> Can a a -> Can a b -> Bool
forall (f :: * -> * -> *) a b c d.
Eq2 f =>
(a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
liftEq2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)

instance Eq2 Can where
  liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> Can a c -> Can b d -> Bool
liftEq2 a -> b -> Bool
_ c -> d -> Bool
_ Can a c
Non Can b d
Non = Bool
True
  liftEq2 a -> b -> Bool
f c -> d -> Bool
_ (One a
a) (One b
c) = a -> b -> Bool
f a
a b
c
  liftEq2 a -> b -> Bool
_ c -> d -> Bool
g (Eno c
b) (Eno d
d) = c -> d -> Bool
g c
b d
d
  liftEq2 a -> b -> Bool
f c -> d -> Bool
g (Two a
a c
b) (Two b
c d
d) = a -> b -> Bool
f a
a b
c Bool -> Bool -> Bool
&& c -> d -> Bool
g c
b d
d
  liftEq2 a -> b -> Bool
_ c -> d -> Bool
_ Can a c
_ Can b d
_ = Bool
False

instance Ord a => Ord1 (Can a) where
  liftCompare :: (a -> b -> Ordering) -> Can a a -> Can a b -> Ordering
liftCompare = (a -> a -> Ordering)
-> (a -> b -> Ordering) -> Can a a -> Can a b -> Ordering
forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

instance Ord2 Can where
  liftCompare2 :: (a -> b -> Ordering)
-> (c -> d -> Ordering) -> Can a c -> Can b d -> Ordering
liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ Can a c
Non Can b d
Non = Ordering
EQ
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ Can a c
Non Can b d
_ = Ordering
LT
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ Can a c
_ Can b d
Non = Ordering
GT
  liftCompare2 a -> b -> Ordering
f c -> d -> Ordering
_ (One a
a) (One b
c) = a -> b -> Ordering
f a
a b
c
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
g (Eno c
b) (Eno d
d) = c -> d -> Ordering
g c
b d
d
  liftCompare2 a -> b -> Ordering
f c -> d -> Ordering
g (Two a
a c
b) (Two b
c d
d) = a -> b -> Ordering
f a
a b
c Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> c -> d -> Ordering
g c
b d
d
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ One{} Can b d
_ = Ordering
LT
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ Can a c
_ One{} = Ordering
GT
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ Can a c
_ Two{} = Ordering
LT
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ Two{} Can b d
_ = Ordering
GT

instance Show a => Show1 (Can a) where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Can a a -> ShowS
liftShowsPrec = (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int
-> Can a a
-> ShowS
forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec [a] -> ShowS
forall a. Show a => [a] -> ShowS
showList

instance Show2 Can where
  liftShowsPrec2 :: (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> Can a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
_ [a] -> ShowS
_ Int -> b -> ShowS
_ [b] -> ShowS
_ Int
_ Can a b
Non = String -> ShowS
showString String
"Non"
  liftShowsPrec2 Int -> a -> ShowS
f [a] -> ShowS
_ Int -> b -> ShowS
_ [b] -> ShowS
_ Int
d (One a
a) = (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> a -> ShowS
f String
"One" Int
d a
a
  liftShowsPrec2 Int -> a -> ShowS
_ [a] -> ShowS
_ Int -> b -> ShowS
g [b] -> ShowS
_ Int
d (Eno b
b) = (Int -> b -> ShowS) -> String -> Int -> b -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> b -> ShowS
g String
"Eno" Int
d b
b
  liftShowsPrec2 Int -> a -> ShowS
f [a] -> ShowS
_ Int -> b -> ShowS
g [b] -> ShowS
_ Int
d (Two a
a b
b) = (Int -> a -> ShowS)
-> (Int -> b -> ShowS) -> String -> Int -> a -> b -> ShowS
forall a b.
(Int -> a -> ShowS)
-> (Int -> b -> ShowS) -> String -> Int -> a -> b -> ShowS
showsBinaryWith Int -> a -> ShowS
f Int -> b -> ShowS
g String
"Two" Int
d a
a b
b

instance Read a => Read1 (Can a) where
  liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Can a a)
liftReadsPrec = (Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS a)
-> ReadS [a]
-> Int
-> ReadS (Can a a)
forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (f a b)
liftReadsPrec2 Int -> ReadS a
forall a. Read a => Int -> ReadS a
readsPrec ReadS [a]
forall a. Read a => ReadS [a]
readList

instance Read2 Can where
  liftReadPrec2 :: ReadPrec a
-> ReadPrec [a] -> ReadPrec b -> ReadPrec [b] -> ReadPrec (Can a b)
liftReadPrec2 ReadPrec a
rpa ReadPrec [a]
_ ReadPrec b
rpb ReadPrec [b]
_ = ReadPrec (Can a b)
forall a b. ReadPrec (Can a b)
nonP ReadPrec (Can a b) -> ReadPrec (Can a b) -> ReadPrec (Can a b)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadPrec (Can a b)
forall b. ReadPrec (Can a b)
oneP ReadPrec (Can a b) -> ReadPrec (Can a b) -> ReadPrec (Can a b)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadPrec (Can a b)
forall a. ReadPrec (Can a b)
enoP ReadPrec (Can a b) -> ReadPrec (Can a b) -> ReadPrec (Can a b)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadPrec (Can a b)
twoP
    where
      nonP :: ReadPrec (Can a b)
nonP = Can a b
forall a b. Can a b
Non Can a b -> ReadPrec () -> ReadPrec (Can a b)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Ident String
"Non")
      oneP :: ReadPrec (Can a b)
oneP = ReadPrec (Can a b) -> ReadPrec (Can a b)
forall a. ReadPrec a -> ReadPrec a
readData (ReadPrec (Can a b) -> ReadPrec (Can a b))
-> ReadPrec (Can a b) -> ReadPrec (Can a b)
forall a b. (a -> b) -> a -> b
$ ReadPrec a -> String -> (a -> Can a b) -> ReadPrec (Can a b)
forall a t. ReadPrec a -> String -> (a -> t) -> ReadPrec t
readUnaryWith ReadPrec a
rpa String
"One" a -> Can a b
forall a b. a -> Can a b
One
      enoP :: ReadPrec (Can a b)
enoP = ReadPrec (Can a b) -> ReadPrec (Can a b)
forall a. ReadPrec a -> ReadPrec a
readData (ReadPrec (Can a b) -> ReadPrec (Can a b))
-> ReadPrec (Can a b) -> ReadPrec (Can a b)
forall a b. (a -> b) -> a -> b
$ ReadPrec b -> String -> (b -> Can a b) -> ReadPrec (Can a b)
forall a t. ReadPrec a -> String -> (a -> t) -> ReadPrec t
readUnaryWith ReadPrec b
rpb String
"Eno" b -> Can a b
forall a b. b -> Can a b
Eno
      twoP :: ReadPrec (Can a b)
twoP = ReadPrec (Can a b) -> ReadPrec (Can a b)
forall a. ReadPrec a -> ReadPrec a
readData (ReadPrec (Can a b) -> ReadPrec (Can a b))
-> ReadPrec (Can a b) -> ReadPrec (Can a b)
forall a b. (a -> b) -> a -> b
$ ReadPrec a
-> ReadPrec b
-> String
-> (a -> b -> Can a b)
-> ReadPrec (Can a b)
forall a b t.
ReadPrec a -> ReadPrec b -> String -> (a -> b -> t) -> ReadPrec t
readBinaryWith ReadPrec a
rpa ReadPrec b
rpb String
"Two" a -> b -> Can a b
forall a b. a -> b -> Can a b
Two

instance NFData a => NFData1 (Can a) where
  liftRnf :: (a -> ()) -> Can a a -> ()
liftRnf = (a -> ()) -> (a -> ()) -> Can a a -> ()
forall (p :: * -> * -> *) a b.
NFData2 p =>
(a -> ()) -> (b -> ()) -> p a b -> ()
liftRnf2 a -> ()
forall a. NFData a => a -> ()
rnf

instance NFData2 Can where
  liftRnf2 :: (a -> ()) -> (b -> ()) -> Can a b -> ()
liftRnf2 a -> ()
f b -> ()
g = \case
    Can a b
Non -> ()
    One a
a -> a -> ()
f a
a
    Eno b
b -> b -> ()
g b
b
    Two a
a b
b -> a -> ()
f a
a () -> () -> ()
`seq` b -> ()
g b
b

instance Hashable a => Hashable1 (Can a) where
  liftHashWithSalt :: (Int -> a -> Int) -> Int -> Can a a -> Int
liftHashWithSalt = (Int -> a -> Int) -> (Int -> a -> Int) -> Int -> Can a a -> Int
forall (t :: * -> * -> *) a b.
Hashable2 t =>
(Int -> a -> Int) -> (Int -> b -> Int) -> Int -> t a b -> Int
liftHashWithSalt2 Int -> a -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt

instance Hashable2 Can where
  liftHashWithSalt2 :: (Int -> a -> Int) -> (Int -> b -> Int) -> Int -> Can a b -> Int
liftHashWithSalt2 Int -> a -> Int
f Int -> b -> Int
g Int
salt = \case
    Can a b
Non -> Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
0 :: Int) Int -> () -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ()
    One a
a -> Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
1 :: Int) Int -> a -> Int
`f` a
a
    Eno b
b -> Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
2 :: Int) Int -> b -> Int
`g` b
b
    Two a
a b
b -> (Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
3 :: Int) Int -> a -> Int
`f` a
a) Int -> b -> Int
`g` b
b

-- -------------------------------------------------------------------- --
-- Normal instances

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 (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 (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"

instance Semigroup a => MonadZip (Can a) where
  mzipWith :: (a -> b -> c) -> Can a a -> Can a b -> Can a c
mzipWith a -> b -> c
f Can a a
a Can a b
b = a -> b -> c
f (a -> b -> c) -> Can a a -> Can a (b -> c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Can a a
a Can a (b -> c) -> Can a b -> Can a c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Can a b
b

instance Semigroup a => Alternative (Can a) where
  empty :: Can a a
empty = Can a a
forall a b. Can a b
Non
  Can a a
Non <|> :: Can a a -> Can a a -> Can a a
<|> Can a a
c = Can a a
c
  Can a a
c <|> Can a a
Non = Can a a
c
  One a
a <|> One a
b = a -> Can a a
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 a
b = a -> a -> Can a a
forall a b. a -> b -> Can a b
Two a
a a
b
  One a
a <|> Two a
b a
c = a -> a -> Can a a
forall a b. a -> b -> Can a b
Two (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b) a
c
  Eno a
a <|> One a
b = a -> a -> Can a a
forall a b. a -> b -> Can a b
Two a
b a
a
  Eno a
_ <|> Can a a
c = Can a a
c
  Two a
a a
b <|> One a
c = a -> a -> Can a a
forall a b. a -> b -> Can a b
Two (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c) a
b
  Two a
a a
_ <|> Eno a
b = a -> a -> Can a a
forall a b. a -> b -> Can a b
Two a
a a
b
  Two a
a a
_ <|> Two a
b a
c = a -> a -> Can a a
forall a b. a -> b -> Can a b
Two (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b) a
c

instance Semigroup a => MonadPlus (Can a)

-- -------------------------------------------------------------------- --
-- 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 Biapplicative Can where
  bipure :: a -> b -> Can a b
bipure = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two

  One a -> b
f <<*>> :: Can (a -> b) (c -> d) -> Can a c -> Can b d
<<*>> One a
a = b -> Can b d
forall a b. a -> Can a b
One (a -> b
f a
a)
  One a -> b
f <<*>> Two a
a c
_ = b -> Can b d
forall a b. a -> Can a b
One (a -> b
f a
a)
  Eno c -> d
g <<*>> Eno c
b = d -> Can b d
forall a b. b -> Can a b
Eno (c -> d
g c
b)
  Eno c -> d
g <<*>> Two a
_ c
b = d -> Can b d
forall a b. b -> Can a b
Eno (c -> d
g c
b)
  Two a -> b
f c -> d
_ <<*>> One a
a = b -> Can b d
forall a b. a -> Can a b
One (a -> b
f a
a)
  Two a -> b
_ c -> d
g <<*>> Eno c
b = d -> Can b d
forall a b. b -> Can a b
Eno (c -> d
g c
b)
  Two a -> b
f c -> d
g <<*>> 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)
  Can (a -> b) (c -> d)
_ <<*>> Can a c
_ = Can b d
forall a b. Can a b
Non

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