{-# 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
  -- * 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.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 Exp) -> Lift (Smash a b)
forall t. (t -> Q Exp) -> Lift t
forall a b. (Lift a, Lift b) => Smash a b -> Q Exp
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
a b :: b
b = \case
  Nowhere -> Smash a b
forall a b. Smash a b
Nada
  Here c :: a
c -> a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash a
c b
b
  There d :: 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 Nada = Maybe a
forall a. Maybe a
Nothing
smashFst (Smash a :: a
a _) = 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 Nada = Maybe b
forall a. Maybe a
Nothing
smashSnd (Smash _ b :: 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 Nada = Bool
True
isNada _ = 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 Nothing = Smash a a
forall a b. Smash a b
Nada
smashDiag (Just a :: 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 -> 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
c _ Nada = c
c
smash _ f :: a -> b -> c
f (Smash a :: a
a b :: 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
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 '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 Nada acc :: [Smash a b]
acc = [Smash a b]
acc
    go a :: Smash a b
a acc :: [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 f :: 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
a b :: b
b) acc :: m
acc = a -> b -> m -> m
f a
a b
b m
acc
    go _ acc :: 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 as :: [a]
as bs :: [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 _ = []

-- | 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 f :: 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 f :: b -> m (Smash a b)
f b :: 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
    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
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 (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 f :: 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 f :: b -> m (Smash a b)
f b :: 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
    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
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 -> Smash a b)
    -> f a
accumUntil :: (b -> Smash a b) -> f a
accumUntil f :: 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 f :: 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 = 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
      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
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

-- | Given a 'Foldable' of 'Smash's, partition it into a tuple of alternatives
-- their parts.
--
partitionSmashes
    :: 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 Nada acc :: (f a, f a)
acc = (f a, f a)
acc
    go (Smash 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 '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 f :: a -> Smash b c
f = t (Smash b c) -> (f b, f c)
forall (t :: * -> *) (f :: * -> *) 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 f :: Smash a b -> Maybe c
f (Just a :: a
a) (Just b :: 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 _ _ _ = 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 _ Nada = Maybe c
forall a. Maybe a
Nothing
smashUncurry f :: Maybe a -> Maybe b -> Maybe c
f (Smash a :: a
a b :: 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
a) c :: 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
b) c :: 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 _ = 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
a c :: 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
b c :: 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 _ = 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
a c :: c
c, Smash b :: b
b _) = (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, 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 Nada = Can (Smash a c) (Smash b c)
forall a b. Can a b
Non
pairSmashCan (Smash cc :: Can a b
cc c :: c
c) = case Can a b
cc of
  Non -> Can (Smash a c) (Smash b c)
forall a b. Can a b
Non
  One a :: 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
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
a b :: 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 cc :: Can (Smash a c) (Smash b c)
cc = case Can (Smash a c) (Smash b c)
cc of
  One (Smash a :: a
a c :: 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
b c :: 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
a c :: c
c) (Smash b :: b
b _) -> 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
  _ -> 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
a b :: b
b) c :: 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 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
a (Smash b :: b
b c :: 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 (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 _ _ Nada Nada = Bool
True
  liftEq2 _ _ Nada _ = Bool
False
  liftEq2 _ _ _ Nada = Bool
False
  liftEq2 f :: a -> b -> Bool
f g :: c -> d -> Bool
g (Smash a :: a
a b :: c
b) (Smash 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

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 _ _ Nada Nada = Ordering
EQ
  liftCompare2 _ _ Nada _ = Ordering
LT
  liftCompare2 _ _ _ Nada = Ordering
GT
  liftCompare2 f :: a -> b -> Ordering
f g :: c -> d -> Ordering
g (Smash a :: a
a b :: c
b) (Smash 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

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 _ _ _ _ _ Nada = String -> ShowS
showString "Nada"
  liftShowsPrec2 f :: Int -> a -> ShowS
f _ g :: Int -> b -> ShowS
g _ d :: Int
d (Smash 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 "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 rpa :: ReadPrec a
rpa _ rpb :: ReadPrec b
rpb _ = 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 "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 "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 f :: a -> ()
f g :: b -> ()
g = \case
    Nada -> ()
    Smash 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 (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 f :: Int -> a -> Int
f g :: Int -> b -> Int
g salt :: Int
salt = \case
    Nada -> 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` ()
    Smash a :: a
a b :: b
b -> (Int
salt Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (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 _ Nada = Smash a b
forall a b. Smash a b
Nada
  fmap f :: a -> b
f (Smash a :: a
a b :: 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

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

  Nada >>= :: Smash a a -> (a -> Smash a b) -> Smash a b
>>= _ = Smash a b
forall a b. Smash a b
Nada
  Smash a :: a
a b :: a
b >>= k :: a -> Smash a b
k = case a -> Smash a b
k a
b of
    Nada -> Smash a b
forall a b. Smash a b
Nada
    Smash c :: a
c d :: 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 f :: a -> b -> c
f a :: Smash a a
a b :: 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
  Nada <> :: Smash a b -> Smash a b -> Smash a b
<> b :: Smash a b
b = Smash a b
b
  a :: Smash a b
a <> Nada = Smash a b
a
  Smash a :: a
a b :: b
b <> Smash c :: a
c d :: 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 Nada = ()
  rnf (Smash 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 (Binary a, Binary b) => Binary (Smash a b) where
  put :: Smash a b -> Put
put Nada = Int -> Put
forall t. Binary t => t -> Put
put @Int 0
  put (Smash a :: a
a b :: b
b) = 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 -> 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
    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
    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
    _ -> String -> Get (Smash a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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
  Nada <|> :: Smash a a -> Smash a a -> Smash a a
<|> c :: Smash a a
c = Smash a a
c
  c :: Smash a a
c <|> Nada = Smash a a
c
  Smash a :: a
a _ <|> Smash c :: a
c d :: 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 f :: a -> b
f g :: c -> d
g = \case
    Nada -> Smash b d
forall a b. Smash a b
Nada
    Smash a :: a
a b :: 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 f :: a -> b
f g :: c -> d
g <<*>> :: Smash (a -> b) (c -> d) -> Smash a c -> Smash b d
<<*>> Smash a :: a
a b :: 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 b d
forall a b. Smash a b
Nada

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