assoc (empty) → 1

raw patch · 4 files changed

+211/−0 lines, 4 filesdep +basedep +bifunctors

Dependencies added: base, bifunctors

Files

LICENSE +30/−0
assoc.cabal +36/−0
src/Data/Bifunctor/Assoc.hs +86/−0
src/Data/Bifunctor/Swap.hs +59/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2017, Oleg Grenrus++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 Oleg Grenrus 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.

+ assoc.cabal view

@@ -0,0 +1,36 @@+cabal-version: 1.12+name:          assoc+version:       1+license:       BSD3+license-file:  LICENSE+synopsis:      swap and assoc: Symmetric and Semigroupy Bifunctors+category:      Data+description:+  Provides generalisations of+  @swap :: (a,b) -> (b,a)@ and+  @assoc :: ((a,b),c) -> (a,(b,c))@+  to+  @Bifunctor@s supporting similar operations (e.g. @Either@, @These@).++author:        Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer:    Oleg Grenrus <oleg.grenrus@iki.fi>++build-type: Simple+tested-with: ghc ==7.0.4 || ==7.2.2 || ==7.4.2 || ==7.6.3 || ==7.8.4 || ==7.10.3 || == 8.0.2 || == 8.2.2 || ==8.4.4 || ==8.6.3++source-repository head+  type:     git+  location: https://github.com/phadej/assoc.git++library+  default-language: Haskell2010+  hs-source-dirs:   src+  build-depends:+      base        >=4.3   && <4.13+    , bifunctors  >=5.5.2 && <5.6++  exposed-modules:+    Data.Bifunctor.Assoc+    Data.Bifunctor.Swap++  other-extensions: TypeFamilies

+ src/Data/Bifunctor/Assoc.hs view

@@ -0,0 +1,86 @@+module Data.Bifunctor.Assoc (+    Assoc (..),+    ) where++import Data.Bifunctor (Bifunctor (..))+import Data.Bifunctor.Flip (Flip (..))+import Data.Bifunctor.Tannen (Tannen (..))+import Data.Bifunctor.Product (Product (..))++-- | "Semigroup-y" 'Bifunctor's.+--+-- @+-- 'assoc' . 'unassoc' = 'id'+-- 'unassoc' . 'assoc' = 'id'+-- 'assoc' . 'bimap' ('bimap' f g) h = 'bimap' f ('bimap' g h) . 'assoc'+-- @+--+-- This library doesn't provide @Monoidal@ class, with left and right unitors.+-- Are they useful in practice?+--+class Bifunctor p => Assoc p where+    assoc :: p (p a b) c -> p a (p b c)+    unassoc :: p a (p b c) -> p (p a b) c++instance Assoc (,) where+    assoc ((a, b), c) = (a, (b, c))+    unassoc (a, (b, c)) = ((a, b), c)++instance Assoc Either where+    assoc (Left (Left a))  = Left a+    assoc (Left (Right b)) = Right (Left b)+    assoc (Right c)        = Right (Right c)++    unassoc (Left a)          = Left (Left a)+    unassoc (Right (Left b))  = Left (Right b)+    unassoc (Right (Right c)) = Right c++instance Assoc p => Assoc (Flip p) where+    assoc   = Flip . first Flip . unassoc . second runFlip . runFlip+    unassoc = Flip . second Flip . assoc . first runFlip . runFlip++-- $setup+--+-- TODO: make proper test-suite+--+-- >>> import Data.Proxy+-- >>> import Test.QuickCheck+-- >>> import Data.Functor.Classes+--+-- >>> :{+--     let assocUnassocLaw :: (Assoc p, Eq2 p) => Proxy p -> p Bool (p Int Char) -> Bool+--         assocUnassocLaw _ x = liftEq2 (==) eq2 (assoc (unassoc x)) x+--     :}+--+-- >>> quickCheck $ assocUnassocLaw (Proxy :: Proxy (,))+-- +++ OK, passed 100 tests.+--+-- >>> quickCheck $ assocUnassocLaw (Proxy :: Proxy Either)+-- +++ OK, passed 100 tests.+--+-- >>> :{+--     let unassocAssocLaw :: (Assoc p, Eq2 p) => Proxy p -> p (p Int Char) Bool -> Bool+--         unassocAssocLaw _ x = liftEq2 eq2 (==) (unassoc (assoc x)) x+--     :}+--+-- >>> quickCheck $ unassocAssocLaw (Proxy :: Proxy (,))+-- +++ OK, passed 100 tests.+--+-- >>> quickCheck $ unassocAssocLaw (Proxy :: Proxy Either)+-- +++ OK, passed 100 tests.+--+-- >>> :{+--     let bimapLaw :: (Assoc p, Eq2 p) => Proxy p+--                  -> Fun Int Char -> Fun Char Bool -> Fun Bool Int+--                  -> p (p Int Char) Bool+--                  -> Bool+--         bimapLaw _ (Fun _ f) (Fun _ g) (Fun _ h) x = liftEq2 (==) eq2+--             (assoc . bimap (bimap f g) h $ x)+--             (bimap f (bimap g h) . assoc $ x)+--     :}+--+-- >>> quickCheck $ bimapLaw (Proxy :: Proxy (,))+-- +++ OK, passed 100 tests.+--+-- >>> quickCheck $ bimapLaw (Proxy :: Proxy Either)+-- +++ OK, passed 100 tests.

+ src/Data/Bifunctor/Swap.hs view

@@ -0,0 +1,59 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Bifunctor.Swap (+    Swap (..),+    ) where++import Data.Bifunctor (Bifunctor (..))+import Data.Bifunctor.Flip (Flip (..))+import Data.Bifunctor.Product (Product (..))+import Data.Bifunctor.Sum (Sum (..))+import Data.Bifunctor.Tannen (Tannen (..))+import Data.Bifunctor.Biff (Biff (..))++import qualified Data.Tuple++-- | Symmetric 'Bifunctor's.+--+-- @+-- 'swap' . 'swap' = 'id'+-- @+--+-- If @p@ is a 'Bifunctor' the following property is assumed to hold:+--+-- @+-- 'swap' . 'bimap' f g = 'bimap' g f . 'swap'+-- @+--+-- 'Swap' isn't a subclass of 'Bifunctor', as for example+--+-- >>> newtype Bipredicate a b = Bipredicate (a -> b -> Bool)+--+-- is not a 'Bifunctor' but has 'Swap' instance+--+-- >>> instance Swap Bipredicate where swap (Bipredicate p) = Bipredicate (flip p)+--+class Swap p where+    swap :: p a b -> p b a++instance Swap (,) where+    swap = Data.Tuple.swap++instance Swap Either where+    swap (Left x) = Right x+    swap (Right x) = Left x++instance Swap p => Swap (Flip p) where+    swap = Flip . swap . runFlip++instance (Swap p, Swap q) => Swap (Product p q) where+    swap (Pair p q) = Pair (swap p) (swap q)++instance (Swap p, Swap q) => Swap (Sum p q) where+    swap (L2 p) = L2 (swap p)+    swap (R2 q) = R2 (swap q)++instance (Functor f, Swap p) => Swap (Tannen f p) where+    swap = Tannen . fmap swap . runTannen++instance (f ~ g, Functor f, Swap p) => Swap (Biff p f g) where+    swap = Biff . swap . runBiff