{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
-- |
-- Module       : Data.Smash
-- Copyright    : (c) 2020 Emily Pillmore
-- License      : BSD-3-Clause
--
-- Maintainer   : Emily Pillmore <emilypi@cohomolo.gy>
-- Stability    : Experimental
-- Portability  : CPP, RankNTypes, TypeApplications
--
-- This module contains the definition for the 'Smash' datatype. In
-- practice, this type is isomorphic to 'Maybe (a,b)' - the type with
-- two possibly non-exclusive values and an empty case.
module Data.Smash
( -- * Datatypes
  -- $general
  Smash(..)
  -- * Combinators
, toSmash
, fromSmash
, smashFst
, smashSnd
, quotSmash
, hulkSmash
, isSmash
, isNada
  -- ** Eliminators
, smash
  -- * Filtering
, smashes
, filterNadas
  -- * Folding
, foldSmashes
, gatherSmashes
  -- * Partitioning
, partitionSmashes
, mapSmashes
  -- * Currying & Uncurrying
, smashCurry
, smashUncurry
  -- * Distributivity
, distributeSmash
, undistributeSmash
, pairSmash
, unpairSmash
, pairSmashCan
, unpairSmashCan
  -- * Associativity
, reassocLR
, reassocRL
  -- * Symmetry
, swapSmash
) where


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

import Data.Bifunctor
import Data.Bifoldable
import Data.Binary (Binary(..))
import Data.Bitraversable
import Data.Can (Can(..), can)
import Data.Data
import Data.Hashable
import Data.Wedge (Wedge(..))
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup (Semigroup(..))
#endif


import GHC.Generics

{- $general

Categorically, the 'Smash' datatype represents a special type of product, a
<https://ncatlab.org/nlab/show/smash+product smash product>, in the category Hask*
of pointed Hask types. The category Hask* consists of Hask types affixed with
a dedicated base point - i.e. all objects look like 'Maybe a'. The smash product is a symmetric, monoidal tensor in Hask* that plays
nicely with the product, 'Can', and coproduct, 'Wedge'. Pictorially,
these datatypes look like this:

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

'Wedge':
                a
                |
Nowhere +-------+
                |
                b


'Smash':


Nada +--------+ (a,b)
@


The fact that smash products form a closed, symmetric monoidal tensor for Hask*
means that we can speak in terms of the language of linear logic for this category.
Namely, we can understand how 'Smash', 'Wedge', and 'Can' interact. 'Can' and 'Wedge'
distribute nicely over each other, and 'Smash' distributes well over 'Wedge', but
is only semi-distributable over 'Wedge''s linear counterpart, which is left
out of the api. In this library, we focus on the fragment of this pointed linear logic
that makes sense to use, and that will be useful to us as Haskell developers.

-}

-- | The 'Smash' data type represents A value which has either an
-- empty case, or two values. The result is a type, 'Smash a b', which is
-- isomorphic to 'Maybe (a,b)'.
--
-- Categorically, the smash product (the quotient of a pointed product by
-- a wedge sum) has interesting properties. It forms a closed
-- symmetric-monoidal tensor in the category Hask* of pointed haskell
-- types (i.e. 'Maybe' values).
--
data Smash a b = Nada | Smash a b
  deriving
    ( Smash a b -> Smash a b -> Bool
(Smash a b -> Smash a b -> Bool)
-> (Smash a b -> Smash a b -> Bool) -> Eq (Smash a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => Smash a b -> Smash a b -> Bool
/= :: Smash a b -> Smash a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => Smash a b -> Smash a b -> Bool
== :: Smash a b -> Smash a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => Smash a b -> Smash a b -> Bool
Eq, Eq (Smash a b)
Eq (Smash a b)
-> (Smash a b -> Smash a b -> Ordering)
-> (Smash a b -> Smash a b -> Bool)
-> (Smash a b -> Smash a b -> Bool)
-> (Smash a b -> Smash a b -> Bool)
-> (Smash a b -> Smash a b -> Bool)
-> (Smash a b -> Smash a b -> Smash a b)
-> (Smash a b -> Smash a b -> Smash a b)
-> Ord (Smash a b)
Smash a b -> Smash a b -> Bool
Smash a b -> Smash a b -> Ordering
Smash a b -> Smash a b -> Smash 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 (Smash a b)
forall a b. (Ord a, Ord b) => Smash a b -> Smash a b -> Bool
forall a b. (Ord a, Ord b) => Smash a b -> Smash a b -> Ordering
forall a b. (Ord a, Ord b) => Smash a b -> Smash a b -> Smash a b
min :: Smash a b -> Smash a b -> Smash a b
$cmin :: forall a b. (Ord a, Ord b) => Smash a b -> Smash a b -> Smash a b
max :: Smash a b -> Smash a b -> Smash a b
$cmax :: forall a b. (Ord a, Ord b) => Smash a b -> Smash a b -> Smash a b
>= :: Smash a b -> Smash a b -> Bool
$c>= :: forall a b. (Ord a, Ord b) => Smash a b -> Smash a b -> Bool
> :: Smash a b -> Smash a b -> Bool
$c> :: forall a b. (Ord a, Ord b) => Smash a b -> Smash a b -> Bool
<= :: Smash a b -> Smash a b -> Bool
$c<= :: forall a b. (Ord a, Ord b) => Smash a b -> Smash a b -> Bool
< :: Smash a b -> Smash a b -> Bool
$c< :: forall a b. (Ord a, Ord b) => Smash a b -> Smash a b -> Bool
compare :: Smash a b -> Smash a b -> Ordering
$ccompare :: forall a b. (Ord a, Ord b) => Smash a b -> Smash a b -> Ordering
$cp1Ord :: forall a b. (Ord a, Ord b) => Eq (Smash a b)
Ord, ReadPrec [Smash a b]
ReadPrec (Smash a b)
Int -> ReadS (Smash a b)
ReadS [Smash a b]
(Int -> ReadS (Smash a b))
-> ReadS [Smash a b]
-> ReadPrec (Smash a b)
-> ReadPrec [Smash a b]
-> Read (Smash a b)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [Smash a b]
forall a b. (Read a, Read b) => ReadPrec (Smash a b)
forall a b. (Read a, Read b) => Int -> ReadS (Smash a b)
forall a b. (Read a, Read b) => ReadS [Smash a b]
readListPrec :: ReadPrec [Smash a b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [Smash a b]
readPrec :: ReadPrec (Smash a b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (Smash a b)
readList :: ReadS [Smash a b]
$creadList :: forall a b. (Read a, Read b) => ReadS [Smash a b]
readsPrec :: Int -> ReadS (Smash a b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (Smash a b)
Read, Int -> Smash a b -> ShowS
[Smash a b] -> ShowS
Smash a b -> String
(Int -> Smash a b -> ShowS)
-> (Smash a b -> String)
-> ([Smash a b] -> ShowS)
-> Show (Smash a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> Smash a b -> ShowS
forall a b. (Show a, Show b) => [Smash a b] -> ShowS
forall a b. (Show a, Show b) => Smash a b -> String
showList :: [Smash a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [Smash a b] -> ShowS
show :: Smash a b -> String
$cshow :: forall a b. (Show a, Show b) => Smash a b -> String
showsPrec :: Int -> Smash a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> Smash a b -> ShowS
Show
    , (forall x. Smash a b -> Rep (Smash a b) x)
-> (forall x. Rep (Smash a b) x -> Smash a b)
-> Generic (Smash a b)
forall x. Rep (Smash a b) x -> Smash a b
forall x. Smash a b -> Rep (Smash a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (Smash a b) x -> Smash a b
forall a b x. Smash a b -> Rep (Smash a b) x
$cto :: forall a b x. Rep (Smash a b) x -> Smash a b
$cfrom :: forall a b x. Smash a b -> Rep (Smash a b) x
Generic, (forall a. Smash a a -> Rep1 (Smash a) a)
-> (forall a. Rep1 (Smash a) a -> Smash a a) -> Generic1 (Smash a)
forall a. Rep1 (Smash a) a -> Smash a a
forall a. Smash a a -> Rep1 (Smash a) a
forall a a. Rep1 (Smash a) a -> Smash a a
forall a a. Smash a a -> Rep1 (Smash 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 (Smash a) a -> Smash a a
$cfrom1 :: forall a a. Smash a a -> Rep1 (Smash a) a
Generic1
    , Typeable, Typeable (Smash a b)
DataType
Constr
Typeable (Smash a b)
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Smash a b -> c (Smash a b))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Smash a b))
-> (Smash a b -> Constr)
-> (Smash a b -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Smash a b)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (Smash a b)))
-> ((forall b. Data b => b -> b) -> Smash a b -> Smash a b)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Smash a b -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Smash a b -> r)
-> (forall u. (forall d. Data d => d -> u) -> Smash a b -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Smash a b -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b))
-> Data (Smash a b)
Smash a b -> DataType
Smash a b -> Constr
(forall b. Data b => b -> b) -> Smash a b -> Smash a b
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Smash a b -> c (Smash a b)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Smash a b)
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Smash 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) -> Smash a b -> u
forall u. (forall d. Data d => d -> u) -> Smash a b -> [u]
forall a b. (Data a, Data b) => Typeable (Smash a b)
forall a b. (Data a, Data b) => Smash a b -> DataType
forall a b. (Data a, Data b) => Smash a b -> Constr
forall a b.
(Data a, Data b) =>
(forall b. Data b => b -> b) -> Smash a b -> Smash a b
forall a b u.
(Data a, Data b) =>
Int -> (forall d. Data d => d -> u) -> Smash a b -> u
forall a b u.
(Data a, Data b) =>
(forall d. Data d => d -> u) -> Smash a b -> [u]
forall a b r r'.
(Data a, Data b) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Smash a b -> r
forall a b r r'.
(Data a, Data b) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Smash a b -> r
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b)
forall a b (m :: * -> *).
(Data a, Data b, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Smash a b -> m (Smash 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 (Smash 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) -> Smash a b -> c (Smash a b)
forall a b (t :: * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Smash 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 (Smash a b))
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Smash a b -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Smash a b -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Smash a b)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Smash a b -> c (Smash a b)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Smash a b))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Smash a b))
$cSmash :: Constr
$cNada :: Constr
$tSmash :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b)
$cgmapMo :: forall a b (m :: * -> *).
(Data a, Data b, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b)
gmapMp :: (forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b)
$cgmapMp :: forall a b (m :: * -> *).
(Data a, Data b, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b)
gmapM :: (forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b)
$cgmapM :: forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
(forall d. Data d => d -> m d) -> Smash a b -> m (Smash a b)
gmapQi :: Int -> (forall d. Data d => d -> u) -> Smash a b -> u
$cgmapQi :: forall a b u.
(Data a, Data b) =>
Int -> (forall d. Data d => d -> u) -> Smash a b -> u
gmapQ :: (forall d. Data d => d -> u) -> Smash a b -> [u]
$cgmapQ :: forall a b u.
(Data a, Data b) =>
(forall d. Data d => d -> u) -> Smash a b -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Smash a b -> r
$cgmapQr :: forall a b r r'.
(Data a, Data b) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Smash a b -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Smash a b -> r
$cgmapQl :: forall a b r r'.
(Data a, Data b) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Smash a b -> r
gmapT :: (forall b. Data b => b -> b) -> Smash a b -> Smash a b
$cgmapT :: forall a b.
(Data a, Data b) =>
(forall b. Data b => b -> b) -> Smash a b -> Smash a b
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Smash 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 (Smash a b))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (Smash a b))
$cdataCast1 :: forall a b (t :: * -> *) (c :: * -> *).
(Data a, Data b, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Smash a b))
dataTypeOf :: Smash a b -> DataType
$cdataTypeOf :: forall a b. (Data a, Data b) => Smash a b -> DataType
toConstr :: Smash a b -> Constr
$ctoConstr :: forall a b. (Data a, Data b) => Smash a b -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Smash 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 (Smash a b)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Smash a b -> c (Smash 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) -> Smash a b -> c (Smash a b)
$cp1Data :: forall a b. (Data a, Data b) => Typeable (Smash a b)
Data
    )

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

-- | Convert a 'Maybe' value into a 'Smash' value
--
toSmash :: Maybe (a,b) -> Smash a b
toSmash :: Maybe (a, b) -> Smash a b
toSmash Maybe (a, b)
Nothing = Smash a b
forall a b. Smash a b
Nada
toSmash (Just (a
a,b
b)) = a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash a
a b
b

-- | Convert a 'Smash' value into a 'Maybe' value
--
fromSmash :: Smash a b -> Maybe (a,b)
fromSmash :: Smash a b -> Maybe (a, b)
fromSmash Smash a b
Nada = Maybe (a, b)
forall a. Maybe a
Nothing
fromSmash (Smash a
a b
b) = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
a,b
b)

-- | Smash product of pointed type modulo its wedge
--
quotSmash :: Can a b -> Smash a b
quotSmash :: Can a b -> Smash a b
quotSmash = Smash a b
-> (a -> Smash a b)
-> (b -> Smash a b)
-> (a -> b -> Smash a b)
-> Can a b
-> Smash a b
forall c a b.
c -> (a -> c) -> (b -> c) -> (a -> b -> c) -> Can a b -> c
can Smash a b
forall a b. Smash a b
Nada (Smash a b -> a -> Smash a b
forall a b. a -> b -> a
const Smash a b
forall a b. Smash a b
Nada) (Smash a b -> b -> Smash a b
forall a b. a -> b -> a
const Smash a b
forall a b. Smash a b
Nada) a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash

-- | Take the smash product of a wedge and two default values
-- to place in either the left or right side of the final product
--
hulkSmash :: a -> b -> Wedge a b -> Smash a b
hulkSmash :: a -> b -> Wedge a b -> Smash a b
hulkSmash a
a b
b = \case
  Wedge a b
Nowhere -> Smash a b
forall a b. Smash a b
Nada
  Here a
c -> a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash a
c b
b
  There b
d -> a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash a
a b
d

-- | Project the left value of a 'Smash' datatype. This is analogous
-- to 'fst' for '(,)'.
--
smashFst :: Smash a b -> Maybe a
smashFst :: Smash a b -> Maybe a
smashFst Smash a b
Nada = Maybe a
forall a. Maybe a
Nothing
smashFst (Smash a
a b
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
a

-- | Project the right value of a 'Smash' datatype. This is analogous
-- to 'snd' for '(,)'.
--
smashSnd :: Smash a b -> Maybe b
smashSnd :: Smash a b -> Maybe b
smashSnd Smash a b
Nada = Maybe b
forall a. Maybe a
Nothing
smashSnd (Smash a
_ b
b) = b -> Maybe b
forall a. a -> Maybe a
Just b
b

-- | Detect whether a 'Smash' value is empty
--
isNada :: Smash a b -> Bool
isNada :: Smash a b -> Bool
isNada Smash a b
Nada = Bool
True
isNada Smash a b
_ = Bool
False

-- | Detect whether a 'Smash' value is not empty
--
isSmash :: Smash a b -> Bool
isSmash :: Smash a b -> Bool
isSmash = Bool -> Bool
not (Bool -> Bool) -> (Smash a b -> Bool) -> Smash a b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Smash a b -> Bool
forall a b. Smash a b -> Bool
isNada

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

-- | Case elimination for the 'Smash' datatype
--
smash :: c -> (a -> b -> c) -> Smash a b -> c
smash :: c -> (a -> b -> c) -> Smash a b -> c
smash c
c a -> b -> c
_ Smash a b
Nada = c
c
smash c
_ a -> b -> c
f (Smash a
a b
b) = a -> b -> c
f a
a b
b

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

-- | Given a 'Foldable' of 'Smash's, collect the values of the
-- 'Smash' cases, if any.
--
smashes :: Foldable f => f (Smash a b) -> [(a,b)]
smashes :: f (Smash a b) -> [(a, b)]
smashes = (Smash a b -> [(a, b)] -> [(a, b)])
-> [(a, b)] -> f (Smash a b) -> [(a, b)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Smash a b -> [(a, b)] -> [(a, b)]
forall a b. Smash a b -> [(a, b)] -> [(a, b)]
go []
  where
    go :: Smash a b -> [(a, b)] -> [(a, b)]
go (Smash 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 Smash a b
_ [(a, b)]
acc = [(a, b)]
acc

-- | Filter the 'Nada' cases of a 'Foldable' of 'Smash' values.
--
filterNadas :: Foldable f => f (Smash a b) -> [Smash a b]
filterNadas :: f (Smash a b) -> [Smash a b]
filterNadas = (Smash a b -> [Smash a b] -> [Smash a b])
-> [Smash a b] -> f (Smash a b) -> [Smash a b]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Smash a b -> [Smash a b] -> [Smash a b]
forall a b. Smash a b -> [Smash a b] -> [Smash a b]
go []
  where
    go :: Smash a b -> [Smash a b] -> [Smash a b]
go Smash a b
Nada [Smash a b]
acc = [Smash a b]
acc
    go Smash a b
a [Smash a b]
acc = Smash a b
aSmash a b -> [Smash a b] -> [Smash a b]
forall a. a -> [a] -> [a]
:[Smash a b]
acc

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

-- | Fold over the 'Smash' case of a 'Foldable' of 'Smash' products by
-- some accumulatig function.
--
foldSmashes
    :: Foldable f
    => (a -> b -> m -> m)
    -> m
    -> f (Smash a b)
    -> m
foldSmashes :: (a -> b -> m -> m) -> m -> f (Smash a b) -> m
foldSmashes a -> b -> m -> m
f = (Smash a b -> m -> m) -> m -> f (Smash a b) -> m
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Smash a b -> m -> m
go
  where
    go :: Smash a b -> m -> m
go (Smash a
a b
b) m
acc = a -> b -> m -> m
f a
a b
b m
acc
    go Smash a b
_ m
acc = m
acc

-- | Gather a 'Smash' product of two lists and product a list of 'Smash'
-- values, mapping the 'Nada' case to the empty list and zipping
-- the two lists together with the 'Smash' constructor otherwise.
--
gatherSmashes :: Smash [a] [b] -> [Smash a b]
gatherSmashes :: Smash [a] [b] -> [Smash a b]
gatherSmashes (Smash [a]
as [b]
bs) = (a -> b -> Smash a b) -> [a] -> [b] -> [Smash a b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash [a]
as [b]
bs
gatherSmashes Smash [a] [b]
_ = []

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

-- | Given a 'Foldable' of 'Smash's, partition it into a tuple of alternatives
-- their parts.
--
partitionSmashes
    :: forall f t a b
    . ( Foldable t
      , Alternative f
      )
    => t (Smash a b) -> (f a, f b)
partitionSmashes :: t (Smash a b) -> (f a, f b)
partitionSmashes = (Smash a b -> (f a, f b) -> (f a, f b))
-> (f a, f b) -> t (Smash a b) -> (f a, f b)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Smash a b -> (f a, f b) -> (f a, f b)
forall (f :: * -> *) (f :: * -> *) a a.
(Alternative f, Alternative f) =>
Smash 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 :: Smash a a -> (f a, f a) -> (f a, f a)
go Smash a a
Nada (f a, f a)
acc = (f a, f a)
acc
    go (Smash 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 'Smash's,
-- and folding over '(<|>)'.
--
mapSmashes
    :: forall f t a b c
    . ( Alternative f
      , Traversable t
      )
    => (a -> Smash b c)
    -> t a
    -> (f b, f c)
mapSmashes :: (a -> Smash b c) -> t a -> (f b, f c)
mapSmashes a -> Smash b c
f = t (Smash b c) -> (f b, f c)
forall (f :: * -> *) (t :: * -> *) a b.
(Foldable t, Alternative f) =>
t (Smash a b) -> (f a, f b)
partitionSmashes (t (Smash b c) -> (f b, f c))
-> (t a -> t (Smash b c)) -> t a -> (f b, f c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Smash b c) -> t a -> t (Smash b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Smash b c
f

-- -------------------------------------------------------------------- --
-- Currying & Uncurrying

-- | "Curry" a map from a smash product to a pointed type. This is analogous
-- to 'curry' for '(->)'.
--
smashCurry :: (Smash a b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
smashCurry :: (Smash a b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
smashCurry Smash a b -> Maybe c
f (Just a
a) (Just b
b) = Smash a b -> Maybe c
f (a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash a
a b
b)
smashCurry Smash a b -> Maybe c
_ Maybe a
_ Maybe b
_ = Maybe c
forall a. Maybe a
Nothing

-- | "Uncurry" a map of pointed types to a map of a smash product to a pointed type.
-- This is analogous to 'uncurry' for '(->)'.
--
smashUncurry :: (Maybe a -> Maybe b -> Maybe c) -> Smash a b -> Maybe c
smashUncurry :: (Maybe a -> Maybe b -> Maybe c) -> Smash a b -> Maybe c
smashUncurry Maybe a -> Maybe b -> Maybe c
_ Smash a b
Nada = Maybe c
forall a. Maybe a
Nothing
smashUncurry Maybe a -> Maybe b -> Maybe c
f (Smash a
a b
b) = Maybe a -> Maybe b -> Maybe c
f (a -> Maybe a
forall a. a -> Maybe a
Just a
a) (b -> Maybe b
forall a. a -> Maybe a
Just b
b)

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


-- | A smash product of wedges is a wedge of smash products.
-- Smash products distribute over coproducts ('Wedge's) in pointed Hask
--
distributeSmash ::  Smash (Wedge a b) c -> Wedge (Smash a c) (Smash b c)
distributeSmash :: Smash (Wedge a b) c -> Wedge (Smash a c) (Smash b c)
distributeSmash (Smash (Here a
a) c
c) = Smash a c -> Wedge (Smash a c) (Smash b c)
forall a b. a -> Wedge a b
Here (a -> c -> Smash a c
forall a b. a -> b -> Smash a b
Smash a
a c
c)
distributeSmash (Smash (There b
b) c
c) = Smash b c -> Wedge (Smash a c) (Smash b c)
forall a b. b -> Wedge a b
There (b -> c -> Smash b c
forall a b. a -> b -> Smash a b
Smash b
b c
c)
distributeSmash Smash (Wedge a b) c
_ = Wedge (Smash a c) (Smash b c)
forall a b. Wedge a b
Nowhere

-- | A wedge of smash products is a smash product of wedges.
-- Smash products distribute over coproducts ('Wedge's) in pointed Hask
--
undistributeSmash :: Wedge (Smash a c) (Smash b c) -> Smash (Wedge a b) c
undistributeSmash :: Wedge (Smash a c) (Smash b c) -> Smash (Wedge a b) c
undistributeSmash (Here (Smash a
a c
c)) = Wedge a b -> c -> Smash (Wedge a b) c
forall a b. a -> b -> Smash a b
Smash (a -> Wedge a b
forall a b. a -> Wedge a b
Here a
a) c
c
undistributeSmash (There (Smash b
b c
c)) = Wedge a b -> c -> Smash (Wedge a b) c
forall a b. a -> b -> Smash a b
Smash (b -> Wedge a b
forall a b. b -> Wedge a b
There b
b) c
c
undistributeSmash Wedge (Smash a c) (Smash b c)
_ = Smash (Wedge a b) c
forall a b. Smash a b
Nada

-- | Distribute a 'Smash' of a pair into a pair of 'Smash's
--
pairSmash :: Smash (a,b) c -> (Smash a c, Smash b c)
pairSmash :: Smash (a, b) c -> (Smash a c, Smash b c)
pairSmash Smash (a, b) c
Nada = (Smash a c
forall a b. Smash a b
Nada, Smash b c
forall a b. Smash a b
Nada)
pairSmash (Smash (a
a,b
b) c
c) = (a -> c -> Smash a c
forall a b. a -> b -> Smash a b
Smash a
a c
c, b -> c -> Smash b c
forall a b. a -> b -> Smash a b
Smash b
b c
c)

-- | Distribute a 'Smash' of a pair into a pair of 'Smash's
--
unpairSmash :: (Smash a c, Smash b c) -> Smash (a,b) c
unpairSmash :: (Smash a c, Smash b c) -> Smash (a, b) c
unpairSmash (Smash a
a c
c, Smash b
b c
_) = (a, b) -> c -> Smash (a, b) c
forall a b. a -> b -> Smash a b
Smash (a
a,b
b) c
c
unpairSmash (Smash a c, Smash b c)
_ = Smash (a, b) c
forall a b. Smash a b
Nada

-- | Distribute a 'Smash' of a 'Can' into a 'Can' of 'Smash's
--
pairSmashCan :: Smash (Can a b) c -> Can (Smash a c) (Smash b c)
pairSmashCan :: Smash (Can a b) c -> Can (Smash a c) (Smash b c)
pairSmashCan Smash (Can a b) c
Nada = Can (Smash a c) (Smash b c)
forall a b. Can a b
Non
pairSmashCan (Smash Can a b
cc c
c) = case Can a b
cc of
  Can a b
Non -> Can (Smash a c) (Smash b c)
forall a b. Can a b
Non
  One a
a -> Smash a c -> Can (Smash a c) (Smash b c)
forall a b. a -> Can a b
One (a -> c -> Smash a c
forall a b. a -> b -> Smash a b
Smash a
a c
c)
  Eno b
b -> Smash b c -> Can (Smash a c) (Smash b c)
forall a b. b -> Can a b
Eno (b -> c -> Smash b c
forall a b. a -> b -> Smash a b
Smash b
b c
c)
  Two a
a b
b -> Smash a c -> Smash b c -> Can (Smash a c) (Smash b c)
forall a b. a -> b -> Can a b
Two (a -> c -> Smash a c
forall a b. a -> b -> Smash a b
Smash a
a c
c) (b -> c -> Smash b c
forall a b. a -> b -> Smash a b
Smash b
b c
c)

-- | Unistribute a 'Can' of 'Smash's into a 'Smash' of 'Can's.
--
unpairSmashCan :: Can (Smash a c) (Smash b c) -> Smash (Can a b) c
unpairSmashCan :: Can (Smash a c) (Smash b c) -> Smash (Can a b) c
unpairSmashCan Can (Smash a c) (Smash b c)
cc = case Can (Smash a c) (Smash b c)
cc of
  One (Smash a
a c
c) -> Can a b -> c -> Smash (Can a b) c
forall a b. a -> b -> Smash a b
Smash (a -> Can a b
forall a b. a -> Can a b
One a
a) c
c
  Eno (Smash b
b c
c) -> Can a b -> c -> Smash (Can a b) c
forall a b. a -> b -> Smash a b
Smash (b -> Can a b
forall a b. b -> Can a b
Eno b
b) c
c
  Two (Smash a
a c
c) (Smash b
b c
_) -> Can a b -> c -> Smash (Can a b) c
forall a b. a -> b -> Smash a b
Smash (a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b) c
c
  Can (Smash a c) (Smash b c)
_ -> Smash (Can a b) c
forall a b. Smash a b
Nada

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

-- | Reassociate a 'Smash' product from left to right.
--
reassocLR :: Smash (Smash a b) c -> Smash a (Smash b c)
reassocLR :: Smash (Smash a b) c -> Smash a (Smash b c)
reassocLR (Smash (Smash a
a b
b) c
c) = a -> Smash b c -> Smash a (Smash b c)
forall a b. a -> b -> Smash a b
Smash a
a (b -> c -> Smash b c
forall a b. a -> b -> Smash a b
Smash b
b c
c)
reassocLR Smash (Smash a b) c
_ = Smash a (Smash b c)
forall a b. Smash a b
Nada

-- | Reassociate a 'Smash' product from right to left.
--
reassocRL :: Smash a (Smash b c) -> Smash (Smash a b) c
reassocRL :: Smash a (Smash b c) -> Smash (Smash a b) c
reassocRL (Smash a
a (Smash b
b c
c)) = Smash a b -> c -> Smash (Smash a b) c
forall a b. a -> b -> Smash a b
Smash (a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash a
a b
b) c
c
reassocRL Smash a (Smash b c)
_ = Smash (Smash a b) c
forall a b. Smash a b
Nada

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

-- | Swap the positions of values in a 'Smash a b' to form a 'Smash b a'.
--
swapSmash :: Smash a b -> Smash b a
swapSmash :: Smash a b -> Smash b a
swapSmash Smash a b
Nada = Smash b a
forall a b. Smash a b
Nada
swapSmash (Smash a
a b
b) = b -> a -> Smash b a
forall a b. a -> b -> Smash a b
Smash b
b a
a

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


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

instance Functor (Smash a) where
  fmap :: (a -> b) -> Smash a a -> Smash a b
fmap a -> b
_ Smash a a
Nada = Smash a b
forall a b. Smash a b
Nada
  fmap a -> b
f (Smash a
a a
b) = a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash a
a (a -> b
f a
b)

instance Monoid a => Applicative (Smash a) where
  pure :: a -> Smash a a
pure = a -> a -> Smash a a
forall a b. a -> b -> Smash a b
Smash a
forall a. Monoid a => a
mempty

  Smash a (a -> b)
Nada <*> :: Smash a (a -> b) -> Smash a a -> Smash a b
<*> Smash a a
_ = Smash a b
forall a b. Smash a b
Nada
  Smash a (a -> b)
_ <*> Smash a a
Nada = Smash a b
forall a b. Smash a b
Nada
  Smash a
a a -> b
f <*> Smash a
c a
d = a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash (a
a a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
c) (a -> b
f a
d)

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

  Smash a a
Nada >>= :: Smash a a -> (a -> Smash a b) -> Smash a b
>>= a -> Smash a b
_ = Smash a b
forall a b. Smash a b
Nada
  Smash a
a a
b >>= a -> Smash a b
k = case a -> Smash a b
k a
b of
    Smash a b
Nada -> Smash a b
forall a b. Smash a b
Nada
    Smash a
c b
d -> a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash (a
a a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
c) b
d

instance (Semigroup a, Semigroup b) => Semigroup (Smash a b) where
  Smash a b
Nada <> :: Smash a b -> Smash a b -> Smash a b
<> Smash a b
b = Smash a b
b
  Smash a b
a <> Smash a b
Nada = Smash a b
a
  Smash a
a b
b <> Smash a
c b
d = a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash (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)

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

instance (NFData a, NFData b) => NFData (Smash a b) where
  rnf :: Smash a b -> ()
rnf Smash a b
Nada = ()
  rnf (Smash a
a b
b) = a -> ()
forall a. NFData a => a -> ()
rnf a
a () -> () -> ()
`seq` b -> ()
forall a. NFData a => a -> ()
rnf b
b

instance (Binary a, Binary b) => Binary (Smash a b) where
  put :: Smash a b -> Put
put Smash a b
Nada = Int -> Put
forall t. Binary t => t -> Put
put @Int Int
0
  put (Smash a
a b
b) = 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 -> 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 (Smash a b)
get = Binary Int => Get Int
forall t. Binary t => Get t
get @Int Get Int -> (Int -> Get (Smash a b)) -> Get (Smash a b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Int
0 -> Smash a b -> Get (Smash a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Smash a b
forall a b. Smash a b
Nada
    Int
1 -> a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash (a -> b -> Smash a b) -> Get a -> Get (b -> Smash 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 -> Smash a b) -> Get b -> Get (Smash 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 (Smash a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid Smash index"

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

instance Bifunctor Smash where
  bimap :: (a -> b) -> (c -> d) -> Smash a c -> Smash b d
bimap a -> b
f c -> d
g = \case
    Smash a c
Nada -> Smash b d
forall a b. Smash a b
Nada
    Smash a
a c
b -> b -> d -> Smash b d
forall a b. a -> b -> Smash a b
Smash (a -> b
f a
a) (c -> d
g c
b)

instance Bifoldable Smash where
  bifoldMap :: (a -> m) -> (b -> m) -> Smash a b -> m
bifoldMap a -> m
f b -> m
g = \case
    Smash a b
Nada -> m
forall a. Monoid a => a
mempty
    Smash 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 Smash where
  bitraverse :: (a -> f c) -> (b -> f d) -> Smash a b -> f (Smash c d)
bitraverse a -> f c
f b -> f d
g = \case
    Smash a b
Nada -> Smash c d -> f (Smash c d)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Smash c d
forall a b. Smash a b
Nada
    Smash a
a b
b -> c -> d -> Smash c d
forall a b. a -> b -> Smash a b
Smash (c -> d -> Smash c d) -> f c -> f (d -> Smash c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
a f (d -> Smash c d) -> f d -> f (Smash c d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> f d
g b
b