{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Data.Smash
(
Smash(..)
, toSmash
, fromSmash
, smashFst
, smashSnd
, quotSmash
, hulkSmash
, isSmash
, isNada
, smash
, smashes
, filterNadas
, foldSmashes
, gatherSmashes
, partitionSmashes
, mapSmashes
, smashCurry
, smashUncurry
, distributeSmash
, undistributeSmash
, pairSmash
, unpairSmash
, pairSmashCan
, unpairSmashCan
, reassocLR
, reassocRL
, swapSmash
) where
import Control.Applicative (Alternative(..))
import Control.DeepSeq (NFData(..))
import Data.Bifunctor
import Data.Bifoldable
import Data.Binary (Binary(..))
import Data.Bitraversable
import Data.Can (Can(..), can)
import Data.Data
import Data.Hashable
import Data.Wedge (Wedge(..))
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup (Semigroup(..))
#endif
import GHC.Generics
data Smash a b = Nada | Smash a b
deriving
( Eq, Ord, Read, Show
, Generic, Generic1
, Typeable, Data
)
toSmash :: Maybe (a,b) -> Smash a b
toSmash Nothing = Nada
toSmash (Just (a,b)) = Smash a b
fromSmash :: Smash a b -> Maybe (a,b)
fromSmash Nada = Nothing
fromSmash (Smash a b) = Just (a,b)
quotSmash :: Can a b -> Smash a b
quotSmash = can Nada (const Nada) (const Nada) Smash
hulkSmash :: a -> b -> Wedge a b -> Smash a b
hulkSmash a b = \case
Nowhere -> Nada
Here c -> Smash c b
There d -> Smash a d
smashFst :: Smash a b -> Maybe a
smashFst Nada = Nothing
smashFst (Smash a _) = Just a
smashSnd :: Smash a b -> Maybe b
smashSnd Nada = Nothing
smashSnd (Smash _ b) = Just b
isNada :: Smash a b -> Bool
isNada Nada = True
isNada _ = False
isSmash :: Smash a b -> Bool
isSmash = not . isNada
smash :: c -> (a -> b -> c) -> Smash a b -> c
smash c _ Nada = c
smash _ f (Smash a b) = f a b
smashes :: Foldable f => f (Smash a b) -> [(a,b)]
smashes = foldr go []
where
go (Smash a b) acc = (a,b) : acc
go _ acc = acc
filterNadas :: Foldable f => f (Smash a b) -> [Smash a b]
filterNadas = foldr go []
where
go Nada acc = acc
go a acc = a:acc
foldSmashes
:: Foldable f
=> (a -> b -> m -> m)
-> m
-> f (Smash a b)
-> m
foldSmashes f = foldr go
where
go (Smash a b) acc = f a b acc
go _ acc = acc
gatherSmashes :: Smash [a] [b] -> [Smash a b]
gatherSmashes (Smash as bs) = zipWith Smash as bs
gatherSmashes _ = []
partitionSmashes
:: forall f t a b
. ( Foldable t
, Alternative f
)
=> t (Smash a b) -> (f a, f b)
partitionSmashes = foldr go (empty, empty)
where
go Nada acc = acc
go (Smash a b) (as, bs) = (pure a <|> as, pure b <|> bs)
mapSmashes
:: forall f t a b c
. ( Alternative f
, Traversable t
)
=> (a -> Smash b c)
-> t a
-> (f b, f c)
mapSmashes f = partitionSmashes . fmap f
smashCurry :: (Smash a b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
smashCurry f (Just a) (Just b) = f (Smash a b)
smashCurry _ _ _ = Nothing
smashUncurry :: (Maybe a -> Maybe b -> Maybe c) -> Smash a b -> Maybe c
smashUncurry _ Nada = Nothing
smashUncurry f (Smash a b) = f (Just a) (Just b)
distributeSmash :: Smash (Wedge a b) c -> Wedge (Smash a c) (Smash b c)
distributeSmash (Smash (Here a) c) = Here (Smash a c)
distributeSmash (Smash (There b) c) = There (Smash b c)
distributeSmash _ = Nowhere
undistributeSmash :: Wedge (Smash a c) (Smash b c) -> Smash (Wedge a b) c
undistributeSmash (Here (Smash a c)) = Smash (Here a) c
undistributeSmash (There (Smash b c)) = Smash (There b) c
undistributeSmash _ = Nada
pairSmash :: Smash (a,b) c -> (Smash a c, Smash b c)
pairSmash Nada = (Nada, Nada)
pairSmash (Smash (a,b) c) = (Smash a c, Smash b c)
unpairSmash :: (Smash a c, Smash b c) -> Smash (a,b) c
unpairSmash (Smash a c, Smash b _) = Smash (a,b) c
unpairSmash _ = Nada
pairSmashCan :: Smash (Can a b) c -> Can (Smash a c) (Smash b c)
pairSmashCan Nada = Non
pairSmashCan (Smash cc c) = case cc of
Non -> Non
One a -> One (Smash a c)
Eno b -> Eno (Smash b c)
Two a b -> Two (Smash a c) (Smash b c)
unpairSmashCan :: Can (Smash a c) (Smash b c) -> Smash (Can a b) c
unpairSmashCan cc = case cc of
One (Smash a c) -> Smash (One a) c
Eno (Smash b c) -> Smash (Eno b) c
Two (Smash a c) (Smash b _) -> Smash (Two a b) c
_ -> Nada
reassocLR :: Smash (Smash a b) c -> Smash a (Smash b c)
reassocLR (Smash (Smash a b) c) = Smash a (Smash b c)
reassocLR _ = Nada
reassocRL :: Smash a (Smash b c) -> Smash (Smash a b) c
reassocRL (Smash a (Smash b c)) = Smash (Smash a b) c
reassocRL _ = Nada
swapSmash :: Smash a b -> Smash b a
swapSmash Nada = Nada
swapSmash (Smash a b) = Smash b a
instance (Hashable a, Hashable b) => Hashable (Smash a b)
instance Functor (Smash a) where
fmap _ Nada = Nada
fmap f (Smash a b) = Smash a (f b)
instance Monoid a => Applicative (Smash a) where
pure = Smash mempty
Nada <*> _ = Nada
_ <*> Nada = Nada
Smash a f <*> Smash c d = Smash (a `mappend` c) (f d)
instance Monoid a => Monad (Smash a) where
return = pure
(>>) = (*>)
Nada >>= _ = Nada
Smash a b >>= k = case k b of
Nada -> Nada
Smash c d -> Smash (a `mappend` c) d
instance (Semigroup a, Semigroup b) => Semigroup (Smash a b) where
Nada <> b = b
a <> Nada = a
Smash a b <> Smash c d = Smash (a <> c) (b <> d)
instance (Semigroup a, Semigroup b) => Monoid (Smash a b) where
mempty = Nada
mappend = (<>)
instance (NFData a, NFData b) => NFData (Smash a b) where
rnf Nada = ()
rnf (Smash a b) = rnf a `seq` rnf b
instance (Binary a, Binary b) => Binary (Smash a b) where
put Nada = put @Int 0
put (Smash a b) = put @Int 1 >> put a >> put b
get = get @Int >>= \case
0 -> pure Nada
1 -> Smash <$> get <*> get
_ -> fail "Invalid Smash index"
instance Bifunctor Smash where
bimap f g = \case
Nada -> Nada
Smash a b -> Smash (f a) (g b)
instance Bifoldable Smash where
bifoldMap f g = \case
Nada -> mempty
Smash a b -> f a `mappend` g b
instance Bitraversable Smash where
bitraverse f g = \case
Nada -> pure Nada
Smash a b -> Smash <$> f a <*> g b