{-# 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
  -- * 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.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 Exp) -> Lift (Can a b)
forall t. (t -> Q Exp) -> Lift t
forall a b. (Lift a, Lift b) => Can a b -> Q Exp
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
c _ _ _ Non = c
c
can _ f :: a -> c
f _ _ (One a :: a
a) = a -> c
f a
a
can _ _ g :: b -> c
g _ (Eno b :: b
b) = b -> c
g b
b
can _ _ _ h :: a -> b -> c
h (Two a :: a
a b :: 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
c _ _ _ Non = c
c
canWithMerge _ f :: a -> c
f _ _ (One a :: a
a) = a -> c
f a
a
canWithMerge _ _ g :: b -> c
g _ (Eno b :: b
b) = b -> c
g b
b
canWithMerge _ f :: a -> c
f g :: b -> c
g m :: c -> c -> c
m (Two a :: a
a b :: 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 f :: a -> c
f g :: 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 f :: a -> m c
f g :: 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 -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
  Two a :: a
a _ -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
  _ -> 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 -> b -> Maybe b
forall a. a -> Maybe a
Just b
b
  Two _ b :: b
b -> b -> Maybe b
forall a. a -> Maybe a
Just b
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 _) = Bool
True
isOne _ = Bool
False

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

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

-- | Detect if a 'Can' is a 'Non' case.
--
isNon :: Can a b -> Bool
isNon :: Can a b -> Bool
isNon Non = Bool
True
isNon _ = 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]
acc = a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc
    go _ acc :: [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]
acc = a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc
    go _ acc :: [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
a b :: b
b) acc :: [(a, b)]
acc = (a
a,b
b)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
acc
    go _ acc :: [(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 _) acc :: [Can a b]
acc = [Can a b]
acc
    go t :: Can a b
t acc :: [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 _) acc :: [Can a b]
acc = [Can a b]
acc
    go t :: Can a b
t acc :: [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 _ _) acc :: [Can a b]
acc = [Can a b]
acc
    go t :: Can a b
t acc :: [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 Non acc :: [Can a b]
acc = [Can a b]
acc
    go t :: Can a b
t acc :: [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 k :: 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
a) acc :: m
acc = a -> m -> m
k a
a m
acc
    go _ acc :: 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 k :: 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
b) acc :: m
acc = b -> m -> m
k b
b m
acc
    go _ acc :: 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 k :: 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
a b :: b
b) acc :: m
acc = a -> b -> m -> m
k a
a b
b m
acc
    go _ acc :: 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 Non = []
gatherCans (One as :: [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 bs :: [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 as :: [a]
as bs :: [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 f :: 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 f :: b -> m (Can a b)
f b :: 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
    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 -> (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' -> (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
a b' :: 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 f :: 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 f :: b -> m (Can a b)
f b :: 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
    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 -> 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' -> (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
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)

-- | 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 f :: 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 f :: 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 = 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
      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 -> (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' -> b -> m (f a)
go (b
b' b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
b)
      Two a :: a
a b' :: 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
$ \aa :: Can a b
aa ~(as :: [a]
as, bs :: [b]
bs, cs :: [(a, b)]
cs) -> case Can a b
aa of
    Non -> ([a]
as, [b]
bs, [(a, b)]
cs)
    One a :: a
a -> (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as, [b]
bs, [(a, b)]
cs)
    Eno b :: b
b -> ([a]
as, b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
bs, [(a, b)]
cs)
    Two a :: a
a b :: 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 (ls :: [a]
ls, []) = [a] -> Can [a] [a]
forall a b. a -> Can a b
One [a]
ls
    go ([], rs :: [a]
rs) = [a] -> Can [a] [a]
forall a b. b -> Can a b
Eno [a]
rs
    go (ls :: [a]
ls, rs :: [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
    :: 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 Non acc :: (f a, f a)
acc = (f a, f a)
acc
    go (One a :: a
a) (as :: f a
as, bs :: 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 b :: a
b) (as :: f a
as, bs :: 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 :: a
b) (as :: f a
as, bs :: 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 f :: a -> Can b c
f = t (Can b c) -> (f b, f c)
forall (t :: * -> *) (f :: * -> *) 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 = 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
    Non -> Can a (Can b c)
forall a b. Can a b
Non
    One c :: Can a b
c -> case Can a b
c of
      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 -> a -> Can a (Can b c)
forall a b. a -> Can a b
One a
a
      Eno b :: 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
a b :: 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
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 c :: Can a b
c d :: c
d -> case Can a b
c of
      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 -> 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
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
a b :: 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
    Non -> Can (Can a b) c
forall a b. Can a b
Non
    One a :: 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 c :: Can b c
c -> case Can b c
c of
      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
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 d :: c
d -> c -> Can (Can a b) c
forall a b. b -> Can a b
Eno c
d
      Two b :: b
b d :: 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
a c :: Can b c
c -> case Can b c
c of
      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
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 d :: 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
b d :: 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 k :: Can a b -> Maybe c
k ma :: Maybe a
ma mb :: Maybe b
mb = case (Maybe a
ma, Maybe b
mb) of
    (Nothing, Nothing) -> Can a b -> Maybe c
k Can a b
forall a b. Can a b
Non
    (Just a :: a
a, Nothing) -> Can a b -> Maybe c
k (a -> Can a b
forall a b. a -> Can a b
One a
a)
    (Nothing, Just b :: 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
a, Just b :: 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 k :: Maybe a -> Maybe b -> Maybe c
k = \case
    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
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
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
a b :: 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 _ _ Non Non = Bool
True
  liftEq2 f :: a -> b -> Bool
f _ (One a :: a
a) (One c :: b
c) = a -> b -> Bool
f a
a b
c
  liftEq2 _ g :: c -> d -> Bool
g (Eno b :: c
b) (Eno d :: d
d) = c -> d -> Bool
g c
b d
d
  liftEq2 f :: a -> b -> Bool
f g :: c -> d -> Bool
g (Two a :: a
a b :: c
b) (Two c :: b
c d :: d
d) = a -> b -> Bool
f a
a b
c Bool -> Bool -> Bool
&& c -> d -> Bool
g c
b d
d
  liftEq2 _ _ _ _ = 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 _ _ Non Non = Ordering
EQ
  liftCompare2 _ _ Non _ = Ordering
LT
  liftCompare2 _ _ _ Non = Ordering
GT
  liftCompare2 f :: a -> b -> Ordering
f _ (One a :: a
a) (One c :: b
c) = a -> b -> Ordering
f a
a b
c
  liftCompare2 _ g :: c -> d -> Ordering
g (Eno b :: c
b) (Eno d :: d
d) = c -> d -> Ordering
g c
b d
d
  liftCompare2 f :: a -> b -> Ordering
f g :: c -> d -> Ordering
g (Two a :: a
a b :: c
b) (Two c :: b
c d :: 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 _ _ One{} _ = Ordering
LT
  liftCompare2 _ _ _ One{} = Ordering
GT
  liftCompare2 _ _ _ Two{} = Ordering
LT
  liftCompare2 _ _ Two{} _ = 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 _ _ _ _ _ Non = String -> ShowS
showString "Non"
  liftShowsPrec2 f :: Int -> a -> ShowS
f _ _ _ d :: Int
d (One a :: a
a) = (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> a -> ShowS
f "One" Int
d a
a
  liftShowsPrec2 _ _ g :: Int -> b -> ShowS
g _ d :: Int
d (Eno b :: b
b) = (Int -> b -> ShowS) -> String -> Int -> b -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> b -> ShowS
g "Eno" Int
d b
b
  liftShowsPrec2 f :: Int -> a -> ShowS
f _ g :: Int -> b -> ShowS
g _ d :: Int
d (Two a :: a
a b :: 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 "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 rpa :: ReadPrec a
rpa _ rpb :: ReadPrec b
rpb _ = 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 "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 "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 "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 "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 f :: a -> ()
f g :: b -> ()
g = \case
    Non -> ()
    One a :: a
a -> a -> ()
f a
a
    Eno b :: b
b -> b -> ()
g b
b
    Two a :: a
a b :: b
b -> a -> ()
f a
a () -> () -> ()
forall a b. a -> b -> b
`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 f :: Int -> a -> Int
f g :: Int -> b -> Int
g salt :: Int
salt = \case
    Non -> Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (0 :: Int) Int -> () -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ()
    One a :: a
a -> Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (1 :: Int) Int -> a -> Int
`f` a
a
    Eno b :: b
b -> Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (2 :: Int) Int -> b -> Int
`g` b
b
    Two a :: a
a b :: b
b -> (Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (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 Non = ()
    rnf (One a :: a
a) = a -> ()
forall a. NFData a => a -> ()
rnf a
a
    rnf (Eno b :: b
b) = b -> ()
forall a. NFData a => a -> ()
rnf b
b
    rnf (Two a :: a
a b :: b
b) = a -> ()
forall a. NFData a => a -> ()
rnf a
a () -> () -> ()
forall a b. a -> b -> b
`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 _ Non = Can a b
forall a b. Can a b
Non
  fmap _ (One a :: a
a) = a -> Can a b
forall a b. a -> Can a b
One a
a
  fmap f :: a -> b
f (Eno b :: a
b) = b -> Can a b
forall a b. b -> Can a b
Eno (a -> b
f a
b)
  fmap f :: a -> b
f (Two a :: a
a b :: 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 k :: a -> m
k (Eno b :: a
b) = a -> m
k a
b
  foldMap k :: a -> m
k (Two _ b :: a
b) = a -> m
k a
b
  foldMap _ _ = m
forall a. Monoid a => a
mempty

instance Traversable (Can a) where
  traverse :: (a -> f b) -> Can a a -> f (Can a b)
traverse k :: a -> f b
k = \case
    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
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 b :: 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 -> 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 -> Can a b
<*> Non = Can a b
forall a b. Can a b
Non
  Non <*> _ = Can a b
forall a b. Can a b
Non
  One a :: a
a <*> _ = a -> Can a b
forall a b. a -> Can a b
One a
a
  Eno _ <*> One b :: a
b = a -> Can a b
forall a b. a -> Can a b
One a
b
  Eno f :: a -> b
f <*> Eno a :: a
a = b -> Can a b
forall a b. b -> Can a b
Eno (a -> b
f a
a)
  Eno f :: a -> b
f <*> Two a :: a
a b :: 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 _ <*> One b :: 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 f :: a -> b
f <*> Eno b :: 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 f :: a -> b
f <*> Two b :: a
b c :: 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
(*>)

  Non >>= :: Can a a -> (a -> Can a b) -> Can a b
>>= _ = Can a b
forall a b. Can a b
Non
  One a :: a
a >>= _ = a -> Can a b
forall a b. a -> Can a b
One a
a
  Eno b :: a
b >>= k :: a -> Can a b
k = a -> Can a b
k a
b
  Two a :: a
a b :: a
b >>= k :: a -> Can a b
k = case a -> Can a b
k a
b of
    Non -> Can a b
forall a b. Can a b
Non
    One c :: 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 c :: b
c -> b -> Can a b
forall a b. b -> Can a b
Eno b
c
    Two c :: a
c d :: 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
  Non <> :: Can a b -> Can a b -> Can a b
<> b :: Can a b
b = Can a b
b
  b :: Can a b
b <> Non = Can a b
b
  One a :: a
a <> One b :: 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
a <> Eno b :: b
b = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b
  One a :: a
a <> Two b :: a
b c :: 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 a :: b
a <> Eno b :: 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
b <> One a :: a
a = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b
  Eno b :: b
b <> Two a :: a
a c :: 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
a b :: b
b <> Two c :: a
c d :: 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
a b :: b
b <> One c :: 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
a b :: b
b <> Eno c :: 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 Non = Int -> Put
forall t. Binary t => t -> Put
put @Int 0
  put (One a :: a
a) = Int -> Put
forall t. Binary t => t -> Put
put @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
b) = Int -> Put
forall t. Binary t => t -> Put
put @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
a b :: b
b) = Int -> Put
forall t. Binary t => t -> Put
put @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
    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
    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
    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
    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
    _ -> String -> Get (Can a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Invalid Can index"

instance Semigroup a => MonadZip (Can a) where
  mzipWith :: (a -> b -> c) -> Can a a -> Can a b -> Can a c
mzipWith f :: a -> b -> c
f a :: Can a a
a b :: 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
  Non <|> :: Can a a -> Can a a -> Can a a
<|> c :: Can a a
c = Can a a
c
  c :: Can a a
c <|> Non = Can a a
c
  One a :: a
a <|> One b :: 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
a <|> Eno b :: a
b = a -> a -> Can a a
forall a b. a -> b -> Can a b
Two a
a a
b
  One a :: a
a <|> Two b :: a
b c :: 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
a <|> One b :: a
b = a -> a -> Can a a
forall a b. a -> b -> Can a b
Two a
b a
a
  Eno _ <|> c :: Can a a
c = Can a a
c
  Two a :: a
a b :: a
b <|> One c :: 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 b :: 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 b :: a
b c :: 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 f :: a -> b
f g :: c -> d
g = \case
    Non -> Can b d
forall a b. Can a b
Non
    One a :: a
a -> b -> Can b d
forall a b. a -> Can a b
One (a -> b
f a
a)
    Eno b :: c
b -> d -> Can b d
forall a b. b -> Can a b
Eno (c -> d
g c
b)
    Two a :: a
a b :: 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 f :: a -> b
f <<*>> :: Can (a -> b) (c -> d) -> Can a c -> Can b d
<<*>> One a :: a
a = b -> Can b d
forall a b. a -> Can a b
One (a -> b
f a
a)
  One f :: a -> b
f <<*>> Two a :: a
a _ = b -> Can b d
forall a b. a -> Can a b
One (a -> b
f a
a)
  Eno g :: c -> d
g <<*>> Eno b :: c
b = d -> Can b d
forall a b. b -> Can a b
Eno (c -> d
g c
b)
  Eno g :: c -> d
g <<*>> Two _ b :: c
b = d -> Can b d
forall a b. b -> Can a b
Eno (c -> d
g c
b)
  Two f :: a -> b
f _ <<*>> One a :: a
a = b -> Can b d
forall a b. a -> Can a b
One (a -> b
f a
a)
  Two _ g :: c -> d
g <<*>> Eno b :: c
b = d -> Can b d
forall a b. b -> Can a b
Eno (c -> d
g c
b)
  Two f :: a -> b
f g :: c -> d
g <<*>> Two a :: a
a b :: 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 b d
forall a b. Can a b
Non

instance Bifoldable Can where
  bifoldMap :: (a -> m) -> (b -> m) -> Can a b -> m
bifoldMap f :: a -> m
f g :: b -> m
g = \case
    Non -> m
forall a. Monoid a => a
mempty
    One a :: a
a -> a -> m
f a
a
    Eno b :: b
b -> b -> m
g b
b
    Two a :: a
a b :: 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 f :: a -> f c
f g :: b -> f d
g = \case
    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
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
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
a b :: 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