diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for possibly-can + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# Smash-core: smash products in Hask diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/smash.cabal b/smash.cabal new file mode 100644 --- /dev/null +++ b/smash.cabal @@ -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 +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 diff --git a/src/Data/Can.hs b/src/Data/Can.hs new file mode 100644 --- /dev/null +++ b/src/Data/Can.hs @@ -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 +-- 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 + +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 diff --git a/src/Data/Smash.hs b/src/Data/Smash.hs new file mode 100644 --- /dev/null +++ b/src/Data/Smash.hs @@ -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 +-- 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 +, 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 diff --git a/src/Data/Wedge.hs b/src/Data/Wedge.hs new file mode 100644 --- /dev/null +++ b/src/Data/Wedge.hs @@ -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 +-- 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 . +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 diff --git a/test/MyLibTest.hs b/test/MyLibTest.hs new file mode 100644 --- /dev/null +++ b/test/MyLibTest.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."