smash (empty) → 0.1.0.0

raw patch · 9 files changed

+1475/−0 lines, 9 filesdep +basedep +bifunctorsdep +ghcflagssetup-changed

Dependencies added: base, bifunctors, ghcflags, hashable

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
smash.cabal +71/−0
src/Data/Can.hs +530/−0
src/Data/Smash.hs +410/−0
src/Data/Wedge.hs +422/−0
test/MyLibTest.hs +4/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for possibly-can++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2020, Emily Pillmore++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Emily Pillmore nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,1 @@+# Smash-core: smash products in Hask

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ smash.cabal view

@@ -0,0 +1,71 @@+cabal-version:       2.0+++name:                smash+version:             0.1.0.0+synopsis:            Smash products - like 'These', but with a unit!+description:+  Smash products are like the 'These' datatype, only with a unit. You can+  think of this type as isomorphic to 'Maybe (These a b)'.++homepage:            https://github.com/emilypi/smash+bug-reports:         https://github.com/emilypi/smash/issues+license:             BSD3+license-file:        LICENSE+author:              Emily Pillmore+maintainer:          emilypi@cohomolo.gy+copyright:           (c) 2020 Emily Pillmore <emilypi@cohomolo.gy>+category:            Data+build-type:          Simple+extra-source-files:+  CHANGELOG.md+  README.md++tested-with:+  GHC ==8.2.2 || ==8.4.3 || ==8.4.4 || ==8.6.3 || ==8.6.5 || ==8.8.3 || ==8.10.1+++source-repository head+  type:     git+  location: https://github.com/emilypi/smash.git+++flag ghc-flags+  description: Generate .ghc.flags files during compilation+  manual:      True+  default:     False++flag perf-flags+  description: Performance tuning flags+  manual:      True+  default:     False++library+  exposed-modules:     Data.Can+                     , Data.Smash+                     , Data.Wedge+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.10 && <5.0+                     , bifunctors+                     , hashable++  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall++  if flag(ghc-flags)+    build-tool-depends: hsinspect:hsinspect+    build-depends: ghcflags+    ghc-options: -fplugin GhcFlags.Plugin++  if flag(perf-flags)+    ghc-options: -ddump-simpl -ddump-to-file+++test-suite tasty+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             MyLibTest.hs+  build-depends:       base >=4.10 && <5.0

+ src/Data/Can.hs view

@@ -0,0 +1,530 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-}+-- |+-- Module       : Data.Can+-- Copyright    : (c) 2020 Emily Pillmore+-- License      : BSD-3-Clause+--+-- Maintainer   : Emily Pillmore <emilypi@cohomolo.gy>+-- Stability    : Experimental+-- Portability  : portable+--+-- This module contains the definition for the 'Can' datatype. In+-- practice, this type is isomorphic to 'Maybe' 'These' - the type with+-- two possibly non-exclusive values and an empty case.+module Data.Can+( -- * Datatypes+  -- $general+  Can(..)+  -- * Combinators+, canFst+, canSnd+, isOne+, isEno+, isTwo+, isNon+  -- ** Eliminators+, can+  -- * Folding+, foldOnes+, foldEnos+, foldTwos+, gatherCans+  -- * Filtering+, ones+, enos+, twos+, filterOnes+, filterEnos+, filterTwos+, filterNons+  -- * Curry & Uncurry+, canCurry+, canUncurry+  -- * Partitioning+, partitionCans+, partitionAll+, partitionEithers+, mapCans+  -- * Distributivity+, distributeCan+, codistributeCan+  -- * Associativity+, reassocLR+, reassocRL+  -- * Symmetry+, swapCan+) where+++import Control.Applicative (Alternative(..))++import Data.Bifunctor+import Data.Bifoldable+import Data.Bitraversable+import Data.Data+import qualified Data.Either as E+import Data.Foldable+import Data.Hashable++import GHC.Generics++{- $general++Categorically, the 'Can' datatype represents the+<https://ncatlab.org/nlab/show/pointed+object#limits_and_colimits pointed product>+in the category Hask* of pointed Hask types. The category Hask* consists of+Hask types affixed with a dedicated base point of an object along with the object - i.e. @'Maybe' a@ in Hask. Hence, the product is+@(1 + a) * (1 + b) ~ 1 + a + b + a*b@, or @'Maybe' ('Either' ('Either' a b) (a,b))@ in Hask. Pictorially, you can visualize+this as:+++@+'Can':+        a+        |+Non +---+---+ (a,b)+        |+        b+@+++The fact that we can think about 'Can' as your average product gives us+some reasoning power about how this thing will be able to interact with the+coproduct in Hask*, called 'Wedge'. Namely, facts about currying+@Can a b -> c ~ a -> b -> c@ and distributivity over 'Wedge'+along with other facts about its associativity, commutativity, and+any other analogy with '(,)' that you can think of.+-}+++-- | The 'Can' data type represents values with two non-exclusive+-- possibilities, as well as an empty case. This is a product of pointed types -+-- i.e. of 'Maybe' values. The result is a type, @'Can' a b@, which is isomorphic+-- to @'Maybe' ('These' a b)@.+--+data Can a b = Non | One a | Eno b | Two a b+  deriving+    ( Eq, Ord, Read, Show+    , Generic, Generic1+    , Typeable, Data+    )++-- -------------------------------------------------------------------- --+-- Eliminators++-- | Case elimination for the 'Can' datatype+--+can+    :: c+      -- ^ default value to supply for the 'Non' case+    -> (a -> c)+      -- ^ eliminator for the 'One' case+    -> (b -> c)+      -- ^ eliminator for the 'Eno' case+    -> (a -> b -> c)+      -- ^ eliminator for the 'Two' case+    -> Can a b+    -> c+can c _ _ _ Non = c+can _ f _ _ (One a) = f a+can _ _ g _ (Eno b) = g b+can _ _ _ h (Two a b) = h a b++-- -------------------------------------------------------------------- --+-- Combinators++-- | Project the left value of a 'Can' datatype. This is analogous+-- to 'fst' for '(,)'.+--+canFst :: Can a b -> Maybe a+canFst = \case+  One a -> Just a+  Two a _ -> Just a+  _ -> Nothing++-- | Project the right value of a 'Can' datatype. This is analogous+-- to 'snd' for '(,)'.+--+canSnd :: Can a b -> Maybe b+canSnd = \case+  Eno b -> Just b+  Two _ b -> Just b+  _ -> Nothing++-- | Detect if a 'Can' is a 'One' case.+--+isOne :: Can a b -> Bool+isOne (One _) = True+isOne _ = False++-- | Detect if a 'Can' is a 'Eno' case.+--+isEno :: Can a b -> Bool+isEno (Eno _) = True+isEno _ = False++-- | Detect if a 'Can' is a 'Two' case.+--+isTwo :: Can a b -> Bool+isTwo (Two _ _) = True+isTwo _ = False++-- | Detect if a 'Can' is a 'Non' case.+--+isNon :: Can a b -> Bool+isNon Non = True+isNon _ = False++-- -------------------------------------------------------------------- --+-- Filtering++-- | Given a 'Foldable' of 'Can's, collect the values of the+-- 'One' cases, if any.+--+ones :: Foldable f => f (Can a b) -> [a]+ones = foldr go []+  where+    go (One a) acc = a:acc+    go _ acc = acc++-- | Given a 'Foldable' of 'Can's, collect the values of the+-- 'Eno' cases, if any.+--+enos :: Foldable f => f (Can a b) -> [b]+enos = foldr go []+  where+    go (Eno a) acc = a:acc+    go _ acc = acc++-- | Given a 'Foldable' of 'Can's, collect the values of the+-- 'Two' cases, if any.+--+twos :: Foldable f => f (Can a b) -> [(a,b)]+twos = foldr go []+  where+    go (Two a b) acc = (a,b):acc+    go _ acc = acc++-- | Filter the 'One' cases of a 'Foldable' of 'Can' values.+--+filterOnes :: Foldable f => f (Can a b) -> [Can a b]+filterOnes = foldr go []+  where+    go (One _) acc = acc+    go t acc = t:acc++-- | Filter the 'Eno' cases of a 'Foldable' of 'Can' values.+--+filterEnos :: Foldable f => f (Can a b) -> [Can a b]+filterEnos = foldr go []+  where+    go (Eno _) acc = acc+    go t acc = t:acc++-- | Filter the 'Two' cases of a 'Foldable' of 'Can' values.+--+filterTwos :: Foldable f => f (Can a b) -> [Can a b]+filterTwos = foldr go []+  where+    go (Two _ _) acc = acc+    go t acc = t:acc++-- | Filter the 'Non' cases of a 'Foldable' of 'Can' values.+--+filterNons :: Foldable f => f (Can a b) -> [Can a b]+filterNons = foldr go []+  where+    go Non acc = acc+    go t acc = t:acc++-- -------------------------------------------------------------------- --+-- Folding++-- | Fold over the 'One' cases of a 'Foldable' of 'Can's by some+-- accumulating function.+--+foldOnes :: Foldable f => (a -> m -> m) -> m -> f (Can a b) -> m+foldOnes k = foldr go+  where+    go (One a) acc = k a acc+    go _ acc = acc++-- | Fold over the 'Eno' cases of a 'Foldable' of 'Can's by some+-- accumulating function.+--+foldEnos :: Foldable f => (b -> m -> m) -> m -> f (Can a b) -> m+foldEnos k = foldr go+  where+    go (Eno b) acc = k b acc+    go _ acc = acc++-- | Fold over the 'Two' cases of a 'Foldable' of 'Can's by some+-- accumulating function.+--+foldTwos :: Foldable f => (a -> b -> m -> m) -> m -> f (Can a b) -> m+foldTwos k = foldr go+  where+    go (Two a b) acc = k a b acc+    go _ acc = acc++-- | Gather a 'Can' of two lists and produce a list of 'Can' values,+-- mapping the 'Non' case to the empty list, One' case to a list+-- of 'One's, the 'Eno' case to a list of 'Eno's, or zipping 'Two'+-- along both lists.+--+gatherCans :: Can [a] [b] -> [Can a b]+gatherCans Non = []+gatherCans (One as) = fmap One as+gatherCans (Eno bs) = fmap Eno bs+gatherCans (Two as bs) = zipWith Two as bs++-- -------------------------------------------------------------------- --+-- Partitioning++-- | Partition a list of 'Can' values into a triple of lists of+-- all of their constituent parts+--+partitionAll :: Foldable f => f (Can a b) -> ([a], [b], [(a,b)])+partitionAll = flip foldr mempty $ \aa ~(as, bs, cs) -> case aa of+    Non -> (as, bs, cs)+    One a -> (a:as, bs, cs)+    Eno b -> (as, b:bs, cs)+    Two a b -> (as, bs, (a,b):cs)++-- | Partition a list of 'Either' values, separating them into+-- a 'Can' value of lists of left and right values, or 'Non' in the+-- case of an empty list.+--+partitionEithers :: Foldable f => f (Either a b) -> Can [a] [b]+partitionEithers = go . E.partitionEithers . toList+  where+    go ([], []) = Non+    go (ls, []) = One ls+    go ([], rs) = Eno rs+    go (ls, rs) = Two ls rs++-- | Given a 'Foldable' of 'Can's, partition it into a tuple of alternatives+-- their parts.+--+partitionCans+    :: forall f t a b+    . ( Foldable t+      , Alternative f+      )+    => t (Can a b) -> (f a, f b)+partitionCans = foldr go (empty, empty)+  where+    go Non acc = acc+    go (One a) (as, bs) = (pure a <|> as, bs)+    go (Eno b) (as, bs) = (as, pure b <|> bs)+    go (Two a b) (as, bs) = (pure a <|> as, pure b <|> bs)++-- | Partition a structure by mapping its contents into 'Can's,+-- and folding over '(<|>)'.+--+mapCans+    :: forall f t a b c+    . ( Alternative f+      , Traversable t+      )+    => (a -> Can b c)+    -> t a+    -> (f b, f c)+mapCans f = partitionCans . fmap f++-- -------------------------------------------------------------------- --+-- Distributivity++-- | Distribute a 'Can' value over a product.+--+distributeCan :: Can (a,b) c -> (Can a c, Can b c)+distributeCan = \case+    Non -> (Non, Non)+    One (a,b) -> (One a, One b)+    Eno c -> (Eno c, Eno c)+    Two (a,b) c -> (Two a c, Two b c)++-- | Codistribute a coproduct over a 'Can' value.+--+codistributeCan :: Either (Can a c) (Can b c) -> Can (Either a b) c+codistributeCan = \case+    Left ac -> case ac of+      Non -> Non+      One a -> One (Left a)+      Eno c -> Eno c+      Two a c -> Two (Left a) c+    Right bc -> case bc of+      Non -> Non+      One b -> One (Right b)+      Eno c -> Eno c+      Two b c -> Two (Right b) c++-- -------------------------------------------------------------------- --+-- Associativity++-- | Re-associate a 'Can' of cans from left to right.+--+reassocLR :: Can (Can a b) c -> Can a (Can b c)+reassocLR = \case+    Non -> Non+    One c -> case c of+      Non -> Eno Non+      One a -> One a+      Eno b -> Eno (One b)+      Two a b -> Two a (One b)+    Eno c -> Eno (Eno c)+    Two c d -> case c of+      Non -> Eno (Eno d)+      One a -> Two a (Eno d)+      Eno b -> Eno (Two b d)+      Two a b -> Two a (Two b d)++-- | Re-associate a 'Can' of cans from right to left.+--+reassocRL :: Can a (Can b c) -> Can (Can a b) c+reassocRL = \case+    Non -> Non+    One a -> One (One a)+    Eno c -> case c of+      Non -> One Non+      One b -> One (Eno b)+      Eno d -> Eno d+      Two b d -> Two (Eno b) d+    Two a c -> case c of+      Non -> One (One a)+      One b -> One (Two a b)+      Eno d -> Two (One a) d+      Two b d -> Two (Two a b) d++-- -------------------------------------------------------------------- --+-- Symmetry++-- | Swap the positions of values in a 'Can'.+--+swapCan :: Can a b -> Can b a+swapCan = \case+    Non -> Non+    One a -> Eno a+    Eno b -> One b+    Two a b -> Two b a++-- -------------------------------------------------------------------- --+-- Curry & Uncurry++-- | Curry a function from a 'Can' to a 'Maybe' value, resulting in a+-- function of curried 'Maybe' values. This is analogous to currying+-- for '(->)'.+--+canCurry :: (Can a b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c+canCurry k ma mb = case (ma, mb) of+    (Nothing, Nothing) -> k Non+    (Just a, Nothing) -> k (One a)+    (Nothing, Just b) -> k (Eno b)+    (Just a, Just b) -> k (Two a b)++-- | "Uncurry" a function from a 'Can' to a 'Maybe' value, resulting in a+-- function of curried 'Maybe' values. This is analogous to uncurrying+-- for '(->)'.+--+canUncurry :: (Maybe a -> Maybe b -> Maybe c) -> Can a b -> Maybe c+canUncurry k = \case+    Non -> k Nothing Nothing+    One a -> k (Just a) Nothing+    Eno b -> k Nothing (Just b)+    Two a b -> k (Just a) (Just b)++-- -------------------------------------------------------------------- --+-- Std instances+++instance (Hashable a, Hashable b) => Hashable (Can a b)++instance Functor (Can a) where+  fmap _ Non = Non+  fmap _ (One a) = One a+  fmap f (Eno b) = Eno (f b)+  fmap f (Two a b) = Two a (f b)++instance Foldable (Can a) where+  foldMap k (Eno b) = k b+  foldMap k (Two _ b) = k b+  foldMap _ _ = mempty++instance Traversable (Can a) where+  traverse k = \case+    Non -> pure Non+    One a -> pure (One a)+    Eno b -> Eno <$> k b+    Two a b -> Two a <$> k b++instance Semigroup a => Applicative (Can a) where+  pure = Eno++  _ <*> Non = Non+  Non <*> _ = Non+  One a <*> _ = One a+  Eno _ <*> One b = One b+  Eno f <*> Eno a = Eno (f a)+  Eno f <*> Two a b = Two a (f b)+  Two a _ <*> One b = One (a <> b)+  Two a f <*> Eno b = Two a (f b)+  Two a f <*> Two b c = Two (a <> b) (f c)++instance Semigroup a => Monad (Can a) where+  return = pure+  (>>) = (*>)++  Non >>= _ = Non+  One a >>= _ = One a+  Eno b >>= k = k b+  Two a b >>= k = case k b of+    Non -> Non+    One c -> One (a <> c)+    Eno c -> Eno c+    Two c d -> Two (a <> c) d++instance (Semigroup a, Semigroup b) => Semigroup (Can a b) where+  Non <> b = b+  b <> Non = b+  One a <> One b = One (a <> b)+  One a <> Eno b = Two a b+  One a <> Two b c = Two (a <> b) c+  Eno a <> Eno b = Eno (a <> b)+  Eno b <> One a = Two a b+  Eno b <> Two a c = Two a (b <> c)+  Two a b <> Two c d = Two (a <> c) (b <> d)+  Two a b <> One c = Two (a <> c) b+  Two a b <> Eno c = Two a (b <> c)+++instance (Semigroup a, Semigroup b) => Monoid (Can a b) where+  mempty = Non++-- -------------------------------------------------------------------- --+-- Bifunctors++instance Bifunctor Can where+  bimap f g = \case+    Non -> Non+    One a -> One (f a)+    Eno b -> Eno (g b)+    Two a b -> Two (f a) (g b)++instance Bifoldable Can where+  bifoldMap f g = \case+    Non -> mempty+    One a -> f a+    Eno b -> g b+    Two a b -> f a <> g b++instance Bitraversable Can where+  bitraverse f g = \case+    Non -> pure Non+    One a -> One <$> f a+    Eno b -> Eno <$> g b+    Two a b -> Two <$> f a <*> g b

+ src/Data/Smash.hs view

@@ -0,0 +1,410 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+-- |+-- Module       : Data.Smash+-- Copyright    : (c) 2020 Emily Pillmore+-- License      : BSD-3-Clause+--+-- Maintainer   : Emily Pillmore <emilypi@cohomolo.gy>+-- Stability    : Experimental+-- Portability  : portable+--+-- This module contains the definition for the 'Smash' datatype. In+-- practice, this type is isomorphic to 'Maybe (a,b)' - the type with+-- two possibly non-exclusive values and an empty case.+module Data.Smash+( -- * Datatypes+  -- $general+  Smash(..)+  -- * Combinators+, toSmash+, fromSmash+, smashFst+, smashSnd+, quotSmash+, hulkSmash+, isSmash+, isNada+  -- ** Eliminators+, smash+  -- * Filtering+, smashes+, filterNadas+  -- * Folding+, foldSmashes+, gatherSmashes+  -- * Partitioning+, partitionSmashes+, mapSmashes+  -- * Currying & Uncurrying+, smashCurry+, smashUncurry+  -- * Distributivity+, distributeSmash+, undistributeSmash+, pairSmash+, unpairSmash+, pairSmashCan+, unpairSmashCan+  -- * Associativity+, reassocLR+, reassocRL+  -- * Symmetry+, swapSmash+) where+++import Control.Applicative (Alternative(..))+import Data.Bifunctor+import Data.Bifoldable+import Data.Bitraversable+import Data.Can (Can(..), can)+import Data.Data+import Data.Hashable+import Data.Wedge (Wedge(..))++import GHC.Generics++{- $general++Categorically, the 'Smash' datatype represents a special type of product, a+<https://ncatlab.org/nlab/show/smash+product smash product>, in the category Hask*+of pointed Hask types. The category Hask* consists of Hask types affixed with+a dedicated base point - i.e. all objects look like 'Maybe a'. The smash product is a symmetric, monoidal tensor in Hask* that plays+nicely with the product, 'Can', and coproduct, 'Wedge'. Pictorially,+these datatypes look like this:++@+'Can':+        a+        |+Non +---+---+ (a,b)+        |+        b++'Wedge':+                a+                |+Nowhere +-------++                |+                b+++'Smash':+++Nada +--------+ (a,b)+@+++The fact that smash products form a closed, symmetric monoidal tensor for Hask*+means that we can speak in terms of the language of linear logic for this category.+Namely, we can understand how 'Smash', 'Wedge', and 'Can' interact. 'Can' and 'Wedge'+distribute nicely over each other, and 'Smash' distributes well over 'Wedge', but+is only semi-distributable over 'Wedge''s linear counterpart, which is left+out of the api. In this library, we focus on the fragment of this pointed linear logic+that makes sense to use, and that will be useful to us as Haskell developers.++-}++-- | The 'Smash' data type represents A value which has either an+-- empty case, or two values. The result is a type, 'Smash a b', which is+-- isomorphic to 'Maybe (a,b)'.+--+-- Categorically, the smash product (the quotient of a pointed product by+-- a wedge sum) has interesting properties. It forms a closed+-- symmetric-monoidal tensor in the category Hask* of pointed haskell+-- types (i.e. 'Maybe' values).+--+data Smash a b = Nada | Smash a b+  deriving+    ( Eq, Ord, Read, Show+    , Generic, Generic1+    , Typeable, Data+    )++-- -------------------------------------------------------------------- --+-- Combinators++-- | Convert a 'Maybe' value into a 'Smash' value+--+toSmash :: Maybe (a,b) -> Smash a b+toSmash Nothing = Nada+toSmash (Just (a,b)) = Smash a b++-- | Convert a 'Smash' value into a 'Maybe' value+--+fromSmash :: Smash a b -> Maybe (a,b)+fromSmash Nada = Nothing+fromSmash (Smash a b) = Just (a,b)++-- | Smash product of pointed type modulo its wedge+--+quotSmash :: Can a b -> Smash a b+quotSmash = can Nada (const Nada) (const Nada) 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 = \case+  Nowhere -> Nada+  Here c -> Smash c b+  There d -> Smash a d++-- | Project the left value of a 'Smash' datatype. This is analogous+-- to 'fst' for '(,)'.+--+smashFst :: Smash a b -> Maybe a+smashFst Nada = Nothing+smashFst (Smash a _) = Just a++-- | Project the right value of a 'Smash' datatype. This is analogous+-- to 'snd' for '(,)'.+--+smashSnd :: Smash a b -> Maybe b+smashSnd Nada = Nothing+smashSnd (Smash _ b) = Just b++-- | Detect whether a 'Smash' value is empty+--+isNada :: Smash a b -> Bool+isNada Nada = True+isNada _ = False++-- | Detect whether a 'Smash' value is not empty+--+isSmash :: Smash a b -> Bool+isSmash = not . isNada++-- -------------------------------------------------------------------- --+-- Eliminators++-- | Case elimination for the 'Smash' datatype+--+smash :: c -> (a -> b -> c) -> Smash a b -> c+smash c _ Nada = c+smash _ f (Smash a b) = f a 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 = foldr go []+  where+    go (Smash a b) acc = (a,b) : acc+    go _ acc = acc++-- | Filter the 'Nada' cases of a 'Foldable' of 'Smash' values.+--+filterNadas :: Foldable f => f (Smash a b) -> [Smash a b]+filterNadas = foldr go []+  where+    go Nada acc = acc+    go a acc = a:acc++-- -------------------------------------------------------------------- --+-- Folding++-- | Fold over the 'Smash' case of a 'Foldable' of 'Smash' products by+-- some accumulatig function.+--+foldSmashes+    :: Foldable f+    => (a -> b -> m -> m)+    -> m+    -> f (Smash a b)+    -> m+foldSmashes f = foldr go+  where+    go (Smash a b) acc = f a b acc+    go _ acc = 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 as bs) = zipWith Smash as bs+gatherSmashes _ = []++-- -------------------------------------------------------------------- --+-- Partitioning++-- | Given a 'Foldable' of 'Smash's, partition it into a tuple of alternatives+-- their parts.+--+partitionSmashes+    :: forall f t a b+    . ( Foldable t+      , Alternative f+      )+    => t (Smash a b) -> (f a, f b)+partitionSmashes = foldr go (empty, empty)+  where+    go Nada acc = acc+    go (Smash a b) (as, bs) = (pure a <|> as, pure b <|> bs)++-- | Partition a structure by mapping its contents into 'Smash's,+-- and folding over '(<|>)'.+--+mapSmashes+    :: forall f t a b c+    . ( Alternative f+      , Traversable t+      )+    => (a -> Smash b c)+    -> t a+    -> (f b, f c)+mapSmashes f = partitionSmashes . fmap 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 f (Just a) (Just b) = f (Smash a b)+smashCurry _ _ _ = 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 _ Nada = Nothing+smashUncurry f (Smash a b) = f (Just a) (Just 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 (Here a) c) = Here (Smash a c)+distributeSmash (Smash (There b) c) = There (Smash b c)+distributeSmash _ = 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 (Here (Smash a c)) = Smash (Here a) c+undistributeSmash (There (Smash b c)) = Smash (There b) c+undistributeSmash _ = 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 Nada = (Nada, Nada)+pairSmash (Smash (a,b) c) = (Smash a c, Smash b c)++-- | Distribute a 'Smash' of a pair into a pair of 'Smash's+--+unpairSmash :: (Smash a c, Smash b c) -> Smash (a,b) c+unpairSmash (Smash a c, Smash b _) = Smash (a,b) c+unpairSmash _ = 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 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)++-- | Unistribute a 'Can' of 'Smash's into a 'Smash' of 'Can's.+--+unpairSmashCan :: Can (Smash a c) (Smash b c) -> Smash (Can a b) c+unpairSmashCan 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++-- -------------------------------------------------------------------- --+-- 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 _ = 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 _ = 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 Nada = Nada+swapSmash (Smash a b) = Smash b a++-- -------------------------------------------------------------------- --+-- Std instances+++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 <> 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 <> 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++-- -------------------------------------------------------------------- --+-- Bifunctors++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 <> g b++instance Bitraversable Smash where+  bitraverse f g = \case+    Nada -> pure Nada+    Smash a b -> Smash <$> f a <*> g b

+ src/Data/Wedge.hs view

@@ -0,0 +1,422 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+-- |+-- Module       : Data.Wedge+-- Copyright    : (c) 2020 Emily Pillmore+-- License      : BSD-3-Clause+--+-- Maintainer   : Emily Pillmore <emilypi@cohomolo.gy>+-- Stability    : Experimental+-- Portability  : portable+--+-- This module contains the definition for the 'Wedge' datatype. In+-- practice, this type is isomorphic to 'Maybe (Either a b)' - the type with+-- two possibly non-exclusive values and an empty case.+module Data.Wedge+( -- * Datatypes+  -- $general+  Wedge(..)+  -- * Combinators+, quotWedge+, wedgeLeft+, wedgeRight+, fromWedge+, toWedge+, isHere+, isThere+, isNowhere+  -- ** Eliminators+, wedge+  -- ** Filtering+, heres+, theres+, filterHeres+, filterTheres+, filterNowheres+  -- ** Folding+, foldHeres+, foldTheres+, gatherWedges+  -- ** Partitioning+, partitionWedges+, mapWedges+  -- ** Distributivity+, distributeWedge+, codistributeWedge+  -- ** Associativity+, reassocLR+, reassocRL+  -- ** Symmetry+, swapWedge+) where+++import Control.Applicative (Alternative(..))++import Data.Bifunctor+import Data.Bifoldable+import Data.Bitraversable+import Data.Data+import Data.Hashable++import GHC.Generics++{- $general++Categorically, the 'Wedge' datatype represents the coproduct (like, 'Either')+in the category Hask* of pointed Hask types, called a <https://ncatlab.org/nlab/show/wedge+sum wedge sum>.+The category Hask* consists of Hask types affixed with+a dedicated base point along with an object. In Hask, this is+equivalent to `1 + a`, also known as 'Maybe a'. Because we can conflate+basepoints of different types (there is only one @Nothing@ type), the wedge sum is+can be viewed as the type `1 + a + b`, or `Maybe (Either a b)` in Hask.+Pictorially, one can visualize this as:+++@+'Wedge':+                a+                |+Nowhere +-------++                |+                b+@+++The fact that we can think about 'Wedge' as a coproduct gives us+some reasoning power about how a 'Wedge' will interact with the+product in Hask*, called 'Can'. Namely, we know that a product of a type and a+coproduct, `a * (b + c)`, is equivalent to `(a + b) * (a + c)`. Additioally,+we may derive other facts about its associativity, distributivity, commutativity, and+any more. As an exercise, think of soemthing `Either` can do. Now do it with 'Wedge'!++-}++-- | The 'Wedge' data type represents values with two exclusive+-- possibilities, and an empty case. This is a coproduct of pointed+-- types - i.e. of 'Maybe' values. The result is a type, 'Wedge a b',+-- which is isomorphic to 'Maybe (Either a b)'.+--+data Wedge a b = Nowhere | Here a | There b+  deriving+    ( Eq, Ord, Read, Show+    , Generic, Generic1+    , Typeable, Data+    )++-- -------------------------------------------------------------------- --+-- Eliminators++-- | Case elimination for the 'Wedge' datatype.+--+wedge+    :: c+    -> (a -> c)+    -> (b -> c)+    -> Wedge a b+    -> c+wedge c _ _ Nowhere = c+wedge _ f _ (Here a) = f a+wedge _ _ g (There b) = g b++-- -------------------------------------------------------------------- --+-- Combinators++-- | Given two possible pointed types, produce a 'Wedge' by+-- considering the left case, the right case, and mapping their+-- 'Nothing' cases to 'Nowhere'. This is a pushout of pointed+-- types `A <- * -> B`.+--+quotWedge :: Either (Maybe a) (Maybe b) -> Wedge a b+quotWedge (Left a) = maybe Nowhere Here a+quotWedge (Right b) = maybe Nowhere There b++-- | Convert a 'Wedge a b' into a 'Maybe (Either a b)' value.+--+fromWedge :: Wedge a b -> Maybe (Either a b)+fromWedge Nowhere = Nothing+fromWedge (Here a) = Just (Left a)+fromWedge (There b) = Just (Right b)++-- | Convert a 'Maybe (Either a b)' value into a 'Wedge'+--+toWedge :: Maybe (Either a b) -> Wedge a b+toWedge Nothing = Nowhere+toWedge (Just e) = either Here There e++-- | Inject a 'Maybe' value into the 'Here' case of a 'Wedge',+-- or 'Nowhere' if the empty case is given. This is analogous to the+-- 'Left' constructor for 'Either'.+--+wedgeLeft :: Maybe a -> Wedge a b+wedgeLeft Nothing = Nowhere+wedgeLeft (Just a) = Here a++-- | Inject a 'Maybe' value into the 'There' case of a 'Wedge',+-- or 'Nowhere' if the empty case is given. This is analogous to the+-- 'Right' constructor for 'Either'.+--+wedgeRight :: Maybe b -> Wedge a b+wedgeRight Nothing = Nowhere+wedgeRight (Just b) = There b++-- | Detect if a 'Wedge' is a 'Here' case.+--+isHere :: Wedge a b -> Bool+isHere = \case+  Here _ -> True+  _ -> False++-- | Detect if a 'Wedge' is a 'There' case.+--+isThere :: Wedge a b -> Bool+isThere = \case+  There _ -> True+  _ -> False++-- | Detect if a 'Wedge' is a 'Nowhere' empty case.+--+isNowhere :: Wedge a b -> Bool+isNowhere = \case+  Nowhere -> True+  _ -> False++-- -------------------------------------------------------------------- --+-- Filtering+++-- | Given a 'Foldable' of 'Wedge's, collect the 'Here' cases, if any.+--+heres :: Foldable f => f (Wedge a b) -> [a]+heres = foldr go mempty+  where+    go (Here a) acc = a:acc+    go _ acc = acc++-- | Given a 'Foldable' of 'Wedge's, collect the 'There' cases, if any.+--+theres :: Foldable f => f (Wedge a b) -> [b]+theres = foldr go mempty+  where+    go (There b) acc = b:acc+    go _ acc = acc++-- | Filter the 'Here' cases of a 'Foldable' of 'Wedge's.+--+filterHeres :: Foldable f => f (Wedge a b) -> [Wedge a b]+filterHeres = foldr go mempty+  where+    go (Here _) acc = acc+    go ab acc = ab:acc++-- | Filter the 'There' cases of a 'Foldable' of 'Wedge's.+--+filterTheres :: Foldable f => f (Wedge a b) -> [Wedge a b]+filterTheres = foldr go mempty+  where+    go (There _) acc = acc+    go ab acc = ab:acc++-- | Filter the 'Nowhere' cases of a 'Foldable' of 'Wedge's.+--+filterNowheres :: Foldable f => f (Wedge a b) -> [Wedge a b]+filterNowheres = foldr go mempty+  where+    go Nowhere acc = acc+    go ab acc = ab:acc++-- -------------------------------------------------------------------- --+-- Filtering++-- | Fold over the 'Here' cases of a 'Foldable' of 'Wedge's by some+-- accumulating function.+--+foldHeres :: Foldable f => (a -> m -> m) -> m -> f (Wedge a b) -> m+foldHeres k = foldr go+  where+    go (Here a) acc = k a acc+    go _ acc = acc++-- | Fold over the 'There' cases of a 'Foldable' of 'Wedge's by some+-- accumulating function.+--+foldTheres :: Foldable f => (b -> m -> m) -> m -> f (Wedge a b) -> m+foldTheres k = foldr go+  where+    go (There b) acc = k b acc+    go _ acc = acc+++-- | Given a 'Wedge' of lists, produce a list of wedges by mapping+-- the list of 'as' to 'Here' values, or the list of 'bs' to 'There'+-- values.+--+gatherWedges :: Wedge [a] [b] -> [Wedge a b]+gatherWedges Nowhere = []+gatherWedges (Here as) = fmap Here as+gatherWedges (There bs) = fmap There bs++-- -------------------------------------------------------------------- --+-- Partitioning++-- | Given a 'Foldable' of 'Wedge's, partition it into a tuple of alternatives+-- their parts.+--+partitionWedges+    :: forall f t a b+    . ( Foldable t+      , Alternative f+      )+    => t (Wedge a b) -> (f a, f b)+partitionWedges = foldr go (empty, empty)+  where+    go Nowhere acc = acc+    go (Here a) (as, bs) = (pure a <|> as, bs)+    go (There b) (as, bs) = (as, pure b <|> bs)++-- | Partition a structure by mapping its contents into 'Wedge's,+-- and folding over '(<|>)'.+--+mapWedges+    :: forall f t a b c+    . ( Alternative f+      , Traversable t+      )+    => (a -> Wedge b c)+    -> t a+    -> (f b, f c)+mapWedges f = partitionWedges . fmap f++-- -------------------------------------------------------------------- --+-- Associativity++-- | Re-associate a 'Wedge' of 'Wedge's from left to right.+--+reassocLR :: Wedge (Wedge a b) c -> Wedge a (Wedge b c)+reassocLR = \case+    Nowhere -> Nowhere+    Here w -> case w of+      Nowhere -> There Nowhere+      Here a -> Here a+      There b -> There (Here b)+    There c -> There (There c)++-- | Re-associate a 'Wedge' of 'Wedge's from left to right.+--+reassocRL :: Wedge a (Wedge b c) -> Wedge (Wedge a b) c+reassocRL = \case+  Nowhere -> Nowhere+  Here a -> Here (Here a)+  There w -> case w of+    Nowhere -> Here Nowhere+    Here b -> Here (There b)+    There c -> There c++-- -------------------------------------------------------------------- --+-- Distributivity++-- | Distribute a 'Wedge' over a product.+--+distributeWedge :: Wedge (a,b) c -> (Wedge a c, Wedge b c)+distributeWedge = \case+  Nowhere -> (Nowhere, Nowhere)+  Here (a,b) -> (Here a, Here b)+  There c -> (There c, There c)++-- | Codistribute 'Wedge's over a coproduct+--+codistributeWedge :: Either (Wedge a c) (Wedge b c) -> Wedge (Either a b) c+codistributeWedge = \case+  Left w -> case w of+    Nowhere -> Nowhere+    Here a -> Here (Left a)+    There c -> There c+  Right w -> case w of+    Nowhere -> Nowhere+    Here b -> Here (Right b)+    There c -> There c++-- -------------------------------------------------------------------- --+-- Symmetry++-- | Swap the positions of the @a@'s and the @b@'s in a 'Wedge'.+--+swapWedge :: Wedge a b -> Wedge b a+swapWedge = \case+  Nowhere -> Nowhere+  Here a -> There a+  There b -> Here b++-- -------------------------------------------------------------------- --+-- Std instances++instance (Hashable a, Hashable b) => Hashable (Wedge a b)++instance Functor (Wedge a) where+  fmap f = \case+    Nowhere -> Nowhere+    Here a -> Here a+    There b -> There (f b)++instance Foldable (Wedge a) where+  foldMap f (There b) = f b+  foldMap _ _ = mempty++instance Traversable (Wedge a) where+  traverse f = \case+    Nowhere -> pure Nowhere+    Here a -> pure (Here a)+    There b -> There <$> f b++instance Semigroup a => Applicative (Wedge a) where+  pure = There++  _ <*> Nowhere = Nowhere+  Nowhere <*> _ = Nowhere+  Here a <*> _ = Here a+  There _ <*> Here b = Here b+  There f <*> There a = There (f a)++instance Semigroup a => Monad (Wedge a) where+  return = pure+  (>>) = (*>)++  Nowhere >>= _ = Nowhere+  Here a >>= _ = Here a+  There b >>= k = k b++instance (Semigroup a, Semigroup b) => Semigroup (Wedge a b) where+  Nowhere <> b = b+  a <> Nowhere = a+  Here a <> Here b = Here (a <> b)+  Here _ <> There b = There b+  There a <> Here _ = There a+  There a <> There b = There (a <> b)++instance (Semigroup a, Semigroup b) => Monoid (Wedge a b) where+  mempty = Nowhere++-- -------------------------------------------------------------------- --+-- Bifunctors++instance Bifunctor Wedge where+  bimap f g = \case+    Nowhere -> Nowhere+    Here a -> Here (f a)+    There b -> There (g b)++instance Bifoldable Wedge where+  bifoldMap f g = \case+    Nowhere -> mempty+    Here a -> f a+    There b -> g b++instance Bitraversable Wedge where+  bitraverse f g = \case+    Nowhere -> pure Nowhere+    Here a -> Here <$> f a+    There b -> There <$> g b

+ test/MyLibTest.hs view

@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."