{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE Safe #-}
-- |
-- Module       : Data.Smash
-- 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 '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(..)
  -- ** Type synonyms
, type (⨳)
  -- * Combinators
, toSmash
, fromSmash
, smashFst
, smashSnd
, quotSmash
, hulkSmash
, isSmash
, isNada
, smashDiag
, smashDiag'
  -- ** Eliminators
, smash
  -- * Filtering
, smashes
, filterNadas
  -- * Folding and Unfolding
, foldSmashes
, gatherSmashes
, unfoldr
, unfoldrM
, iterateUntil
, iterateUntilM
, accumUntil
, accumUntilM
  -- * Partitioning
, partitionSmashes
, mapSmashes
, eqSmash
  -- * Currying & Uncurrying
, smashCurry
, smashUncurry
  -- * Distributivity
, distributeSmash
, undistributeSmash
, pairSmash
, unpairSmash
, pairSmashCan
, unpairSmashCan
  -- * Associativity
, reassocLR
, reassocRL
  -- * Symmetry
, swapSmash
) where


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

import Data.Biapplicative
import Data.Bifoldable
import Data.Binary (Binary(..))
import Data.Bitraversable
import Data.Can (Can(..), can)
import Data.Data
import Data.Functor.Classes
import Data.Functor.Contravariant (Equivalence(..))
import Data.Functor.Identity
import Data.Hashable
import Data.Wedge (Wedge(..))

import GHC.Generics
import GHC.Read

import Text.Read hiding (get)

import Data.Smash.Internal
import qualified Language.Haskell.TH.Syntax as TH
import Control.Monad
import Data.Hashable.Lifted


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

-- | A type operator synonym for 'Smash'
--
type a ⨳ b = Smash a b

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

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

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

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

-- | Create a smash product of self-similar values from a pointed object.
--
-- This is the diagonal morphism in Hask*.
--
smashDiag :: Maybe a -> Smash a a
smashDiag :: Maybe a -> Smash a a
smashDiag Maybe a
Nothing = Smash a a
forall a b. Smash a b
Nada
smashDiag (Just a
a) = a -> a -> Smash a a
forall a b. a -> b -> Smash a b
Smash a
a a
a

-- | See: 'smashDiag'. This is always a 'Smash' value.
--
smashDiag' :: a -> Smash a a
smashDiag' :: a -> Smash a a
smashDiag' a
a = a -> a -> Smash a a
forall a b. a -> b -> Smash a b
Smash a
a a
a

-- -------------------------------------------------------------------- --
-- 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 accumulating 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]
_ = []

-- | Unfold from right to left into a smash product
--
unfoldr :: Alternative f => (b -> Smash a b) -> b -> f a
unfoldr :: (b -> Smash a b) -> b -> f a
unfoldr b -> Smash 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 (Smash a b)) -> b -> Identity (f a)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Alternative f) =>
(b -> m (Smash a b)) -> b -> m (f a)
unfoldrM (Smash a b -> Identity (Smash a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Smash a b -> Identity (Smash a b))
-> (b -> Smash a b) -> b -> Identity (Smash a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Smash a b
f)

-- | Unfold from right to left into a monadic computation over a smash product
--
unfoldrM :: (Monad m, Alternative f) => (b -> m (Smash a b)) -> b -> m (f a)
unfoldrM :: (b -> m (Smash a b)) -> b -> m (f a)
unfoldrM b -> m (Smash a b)
f b
b = b -> m (Smash a b)
f b
b m (Smash a b) -> (Smash a b -> m (f a)) -> m (f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Smash a b
Nada -> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
forall (f :: * -> *) a. Alternative f => f a
empty
    Smash a
a b
b' -> (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>) (f a -> f a) -> m (f a) -> m (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b -> m (Smash a b)) -> b -> m (f a)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Alternative f) =>
(b -> m (Smash a b)) -> b -> m (f a)
unfoldrM b -> m (Smash a b)
f b
b'

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

-- | Iterate on a seed, which may result in one of two scenarios:
--
--   1. The function yields a @Nada@ value, which terminates the
--      iteration.
--
--   2. The function yields a @Smash@ value.
--
iterateUntilM
    :: Monad m
    => Alternative f
    => (b -> m (Smash a b))
    -> b
    -> m (f a)
iterateUntilM :: (b -> m (Smash a b)) -> b -> m (f a)
iterateUntilM b -> m (Smash a b)
f b
b = b -> m (Smash a b)
f b
b m (Smash a b) -> (Smash a b -> m (f a)) -> m (f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Smash a b
Nada -> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
forall (f :: * -> *) a. Alternative f => f a
empty
    Smash a
a b
_ -> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)

-- | Iterate on a seed, accumulating values and monoidally
-- updating the seed with each update.
--
accumUntil
    :: Alternative f
    => Monoid b
    => (b -> Smash a b)
    -> f a
accumUntil :: (b -> Smash a b) -> f a
accumUntil b -> Smash a b
f = Identity (f a) -> f a
forall a. Identity a -> a
runIdentity ((b -> Identity (Smash a b)) -> Identity (f a)
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Alternative f, Monoid b) =>
(b -> m (Smash a b)) -> m (f a)
accumUntilM (Smash a b -> Identity (Smash a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Smash a b -> Identity (Smash a b))
-> (b -> Smash a b) -> b -> Identity (Smash a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Smash 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 (Smash a b))
    -> m (f a)
accumUntilM :: (b -> m (Smash a b)) -> m (f a)
accumUntilM b -> m (Smash a b)
f = b -> m (f a)
forall (f :: * -> *). Alternative f => b -> m (f a)
go b
forall a. Monoid a => a
mempty
  where
    go :: b -> m (f a)
go b
b = b -> m (Smash a b)
f b
b m (Smash a b) -> (Smash a b -> m (f a)) -> m (f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Smash a b
Nada -> f a -> m (f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
forall (f :: * -> *) a. Alternative f => f a
empty
      Smash a
a b
b' -> (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>) (f a -> f a) -> m (f a) -> m (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> m (f a)
go (b
b' b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
b)

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

-- | Given a 'Foldable' of 'Smash's, partition it into a tuple of alternatives
-- their parts.
--
partitionSmashes
    :: Alternative f
    => Foldable t
    => 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
    :: 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.
(Alternative f, Foldable t) =>
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

-- | Equivalence relation formed by grouping of equal 'Smash' constructors.
--
eqSmash :: Equivalence (Smash a b)
eqSmash :: Equivalence (Smash a b)
eqSmash = (Smash a b -> Smash a b -> Bool) -> Equivalence (Smash a b)
forall a. (a -> a -> Bool) -> Equivalence a
Equivalence Smash a b -> Smash a b -> Bool
forall a b. Smash a b -> Smash a b -> Bool
equivalence
  where
    equivalence :: Smash a b -> Smash a b -> Bool
    equivalence :: Smash a b -> Smash a b -> Bool
equivalence Smash a b
Nada        Smash a b
Nada        = Bool
True
    equivalence (Smash a
_ b
_) (Smash a
_ b
_) = Bool
True
    equivalence Smash a b
_           Smash a b
_           = Bool
False

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

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

-- | Undistribute 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 b a -> (a -> b -> Smash b a) -> Smash a b -> Smash b a
forall c a b. c -> (a -> b -> c) -> Smash a b -> c
smash Smash b a
forall a b. Smash a b
Nada ((b -> a -> Smash b a) -> a -> b -> Smash b a
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> a -> Smash b a
forall a b. a -> b -> Smash a b
Smash)

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

instance Eq a => Eq1 (Smash a) where
  liftEq :: (a -> b -> Bool) -> Smash a a -> Smash a b -> Bool
liftEq = (a -> a -> Bool)
-> (a -> b -> Bool) -> Smash a a -> Smash 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 Smash where
  liftEq2 :: (a -> b -> Bool)
-> (c -> d -> Bool) -> Smash a c -> Smash b d -> Bool
liftEq2 a -> b -> Bool
_ c -> d -> Bool
_ Smash a c
Nada Smash b d
Nada = Bool
True
  liftEq2 a -> b -> Bool
_ c -> d -> Bool
_ Smash a c
Nada Smash b d
_ = Bool
False
  liftEq2 a -> b -> Bool
_ c -> d -> Bool
_ Smash a c
_ Smash b d
Nada = Bool
False
  liftEq2 a -> b -> Bool
f c -> d -> Bool
g (Smash a
a c
b) (Smash b
c d
d) = a -> b -> Bool
f a
a b
c Bool -> Bool -> Bool
&& c -> d -> Bool
g c
b d
d

instance Ord a => Ord1 (Smash a) where
  liftCompare :: (a -> b -> Ordering) -> Smash a a -> Smash a b -> Ordering
liftCompare = (a -> a -> Ordering)
-> (a -> b -> Ordering) -> Smash a a -> Smash 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 Smash where
  liftCompare2 :: (a -> b -> Ordering)
-> (c -> d -> Ordering) -> Smash a c -> Smash b d -> Ordering
liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ Smash a c
Nada Smash b d
Nada = Ordering
EQ
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ Smash a c
Nada Smash b d
_ = Ordering
LT
  liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
_ Smash a c
_ Smash b d
Nada = Ordering
GT
  liftCompare2 a -> b -> Ordering
f c -> d -> Ordering
g (Smash a
a c
b) (Smash b
c d
d) = a -> b -> Ordering
f a
a b
c Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> c -> d -> Ordering
g c
b d
d

instance Show a => Show1 (Smash a) where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Smash a a -> ShowS
liftShowsPrec = (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int
-> Smash 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 Smash where
  liftShowsPrec2 :: (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> Smash a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
_ [a] -> ShowS
_ Int -> b -> ShowS
_ [b] -> ShowS
_ Int
_ Smash a b
Nada = String -> ShowS
showString String
"Nada"
  liftShowsPrec2 Int -> a -> ShowS
f [a] -> ShowS
_ Int -> b -> ShowS
g [b] -> ShowS
_ Int
d (Smash a
a b
b) = (Int -> a -> ShowS)
-> (Int -> b -> ShowS) -> String -> Int -> a -> b -> ShowS
forall a b.
(Int -> a -> ShowS)
-> (Int -> b -> ShowS) -> String -> Int -> a -> b -> ShowS
showsBinaryWith Int -> a -> ShowS
f Int -> b -> ShowS
g String
"Smash" Int
d a
a b
b

instance Read a => Read1 (Smash a) where
  liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Smash a a)
liftReadsPrec = (Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS a)
-> ReadS [a]
-> Int
-> ReadS (Smash 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 Smash where
  liftReadPrec2 :: ReadPrec a
-> ReadPrec [a]
-> ReadPrec b
-> ReadPrec [b]
-> ReadPrec (Smash a b)
liftReadPrec2 ReadPrec a
rpa ReadPrec [a]
_ ReadPrec b
rpb ReadPrec [b]
_ = ReadPrec (Smash a b)
forall a b. ReadPrec (Smash a b)
nadaP ReadPrec (Smash a b)
-> ReadPrec (Smash a b) -> ReadPrec (Smash a b)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadPrec (Smash a b)
smashP
    where
      nadaP :: ReadPrec (Smash a b)
nadaP = Smash a b
forall a b. Smash a b
Nada Smash a b -> ReadPrec () -> ReadPrec (Smash a b)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Ident String
"Nada")
      smashP :: ReadPrec (Smash a b)
smashP = ReadPrec (Smash a b) -> ReadPrec (Smash a b)
forall a. ReadPrec a -> ReadPrec a
readData (ReadPrec (Smash a b) -> ReadPrec (Smash a b))
-> ReadPrec (Smash a b) -> ReadPrec (Smash a b)
forall a b. (a -> b) -> a -> b
$ ReadPrec a
-> ReadPrec b
-> String
-> (a -> b -> Smash a b)
-> ReadPrec (Smash a b)
forall a b t.
ReadPrec a -> ReadPrec b -> String -> (a -> b -> t) -> ReadPrec t
readBinaryWith ReadPrec a
rpa ReadPrec b
rpb String
"Smash" a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash

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

instance NFData2 Smash where
  liftRnf2 :: (a -> ()) -> (b -> ()) -> Smash a b -> ()
liftRnf2 a -> ()
f b -> ()
g = \case
    Smash a b
Nada -> ()
    Smash a
a b
b -> a -> ()
f a
a () -> () -> ()
`seq` b -> ()
g b
b

instance Hashable a => Hashable1 (Smash a) where
  liftHashWithSalt :: (Int -> a -> Int) -> Int -> Smash a a -> Int
liftHashWithSalt = (Int -> a -> Int) -> (Int -> a -> Int) -> Int -> Smash 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 Smash where
  liftHashWithSalt2 :: (Int -> a -> Int) -> (Int -> b -> Int) -> Int -> Smash a b -> Int
liftHashWithSalt2 Int -> a -> Int
f Int -> b -> Int
g Int
salt = \case
    Smash a b
Nada -> Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
0 :: Int) Int -> () -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ()
    Smash a
a b
b -> (Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Int
1 :: Int) Int -> a -> Int
`f` a
a) Int -> b -> Int
`g` b
b

-- -------------------------------------------------------------------- --
-- 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. Semigroup a => a -> a -> a
<> 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. Semigroup a => a -> a -> a
<> a
c) b
d

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

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"

instance Monoid a => Alternative (Smash a) where
  empty :: Smash a a
empty = Smash a a
forall a b. Smash a b
Nada
  Smash a a
Nada <|> :: Smash a a -> Smash a a -> Smash a a
<|> Smash a a
c = Smash a a
c
  Smash a a
c <|> Smash a a
Nada = Smash a a
c
  Smash a
a a
_ <|> Smash a
c a
d = a -> a -> Smash a a
forall a b. a -> b -> Smash a b
Smash (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c) a
d

instance Monoid a => MonadPlus (Smash a)

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

  Smash a -> b
f c -> d
g <<*>> :: Smash (a -> b) (c -> d) -> Smash a c -> Smash b d
<<*>> 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)
  Smash (a -> b) (c -> d)
_ <<*>> Smash a c
_ = Smash b d
forall a b. Smash a b
Nada

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