diff --git a/CHANGELOG.md b/CHANGELOG.md index 268e2d4..bc5baeb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,7 @@ Notable changes to this project are documented in this file. The format is based Breaking changes (😱!!!): New features: +- Added three new classes: `Align`, `Alignable`, and `Crosswalk` (#29 by @vladciobanu) Bugfixes: diff --git a/spago.dhall b/spago.dhall index 132689e..d9346ba 100644 --- a/spago.dhall +++ b/spago.dhall @@ -1,5 +1,5 @@ { name = "these" -, dependencies = [ "console", "effect", "gen", "psci-support", "tuples" ] +, dependencies = [ "console", "effect", "gen", "psci-support", "tuples", "arrays", "lists", "quickcheck", "quickcheck-laws" ] , packages = ./packages.dhall , sources = [ "src/**/*.purs", "test/**/*.purs" ] } diff --git a/src/Data/Align.purs b/src/Data/Align.purs new file mode 100644 index 0000000..d081d68 --- /dev/null +++ b/src/Data/Align.purs @@ -0,0 +1,146 @@ +module Data.Align where + +import Prelude + +import Data.Array as A +import Data.Foldable (class Foldable) +import Data.List as List +import Data.List.Lazy as LazyList +import Data.Maybe (Maybe(..)) +import Data.Newtype (unwrap) +import Data.These (These(..), these) + +-- | The `Align` type class represents an operation similar to `Apply` with +-- | slightly different semantics. For example: +-- | +-- | ```purescript +-- | > align identity (Just 1) Nothing :: These Int Int +-- | This 1 +-- | ``` +-- | +-- | Instances are required to satisfy the following laws: +-- | +-- | - Idempotency: `join (align identity) == map (join These)` +-- | - Commutativity `align identity x y == swap <$> align identity y x` +-- | - Associativity `align identity x (align identity y z) == assoc <$> align identity (align identity x y) z` +-- | - Functoriality `align identity (f <$> x) (g <$> y) ≡ bimap f g <$> align identity x y` +class (Functor f) <= Align f where + align :: forall a b c. (These a b -> c) -> f a -> f b -> f c + +instance alignArray :: Align Array where + align f xs [] = f <<< This <$> xs + align f [] ys = f <<< That <$> ys + align f xs ys = A.zipWith f' xs ys <> align f xs' ys' + where + f' x y = f (Both x y) + xs' = A.drop (A.length ys) xs + ys' = A.drop (A.length xs) ys + +instance alignList :: Align List.List where + align f xs List.Nil = f <<< This <$> xs + align f List.Nil ys = f <<< That <$> ys + align f (List.Cons x xs) (List.Cons y ys) = f (Both x y) `List.Cons` align f xs ys + +instance alignLazyList :: Align LazyList.List where + align f xs ys = LazyList.List $ go <$> unwrap xs <*> unwrap ys + where + go LazyList.Nil LazyList.Nil = LazyList.Nil + go (LazyList.Cons x xs') LazyList.Nil = f (This x) `LazyList.Cons` align f xs' mempty + go LazyList.Nil (LazyList.Cons y ys') = f (That y) `LazyList.Cons` align f mempty ys' + go (LazyList.Cons x xs') (LazyList.Cons y ys') = f (Both x y) `LazyList.Cons` align f xs' ys' + +instance alignMaybe :: Align Maybe where + align f ma Nothing = f <<< This <$> ma + align f Nothing mb = f <<< That <$> mb + align f (Just a) (Just b) = Just $ f (Both a b) + +-- | Convenience combinator for `align identity`. +aligned :: forall a b f. Align f => f a -> f b -> f (These a b) +aligned = align identity + +-- | `Alignable` adds an identity value for the `align` operation. +-- | +-- | Instances are required to satisfy the following laws: +-- | +-- | - Left Identity: `align identity nil x == fmap That x` +-- | - Right Identity: `align identity x nil ≡ fmap This x` +class (Align f) <= Alignable f where + nil :: forall a. f a + +instance alignableArray :: Alignable Array where + nil = mempty + +instance alignableList :: Alignable List.List where + nil = mempty + +instance alignableLazyList :: Alignable LazyList.List where + nil = mempty + +instance alignableMaybe :: Alignable Maybe where + nil = Nothing + +-- | `Crosswalk` is similar to `Traversable`, but uses the `Align`/`Alignable` +-- | semantics instead of `Apply`/`Applicative` for combining values. +-- | +-- | For example: +-- | ```purescript +-- | > traverse Int.fromString ["1", "2", "3"] +-- | Just [1, 2, 3] +-- | > crosswalk Int.fromString ["1", "2", "3"] +-- | Just [1, 2, 3] +-- | +-- | > traverse Int.fromString ["a", "b", "c"] +-- | Nothing +-- | > crosswalk Int.fromString ["a", "b", "c"] +-- | Nothing +-- | +-- | > traverse Int.fromString ["1", "b", "3"] +-- | Nothing +-- | > crosswalk Int.fromString ["1", "b", "3"] +-- | Just [1, 3] +-- | +-- | > traverse Int.fromString [] +-- | Just [] +-- | > crosswalk Int.fromString [] +-- | Nothing +-- | ``` +-- | +-- | Instances are required to satisfy the following laws: +-- | +-- | - Annihilation: `crosswalk (const nil) == const nil` +class (Foldable f, Functor f) <= Crosswalk f where + crosswalk :: forall t a b. Alignable t => (a -> t b) -> f a -> t (f b) + +instance crosswalkThese :: Crosswalk (These a) where + crosswalk f = case _ of + This _ -> nil + That x -> That <$> f x + Both a x -> Both a <$> f x + +instance crosswalkArray :: Crosswalk Array where + crosswalk f xs = case A.uncons xs of + Nothing -> nil + Just { head, tail } -> align cons (f head) (crosswalk f tail) + where + cons = these pure identity A.cons + +instance crosswalkList :: Crosswalk List.List where + crosswalk f = case _ of + List.Nil -> nil + List.Cons x xs -> align cons (f x) (crosswalk f xs) + where + cons = these pure identity List.Cons + +instance crosswalkLazyList :: Crosswalk LazyList.List where + crosswalk f l = + case LazyList.step l of + LazyList.Nil -> nil + LazyList.Cons x xs -> align cons (f x) (crosswalk f xs) + where + cons = these pure identity LazyList.cons + +instance crosswalkMaybe :: Crosswalk Maybe where + crosswalk f = case _ of + Nothing -> nil + Just a -> Just <$> f a + diff --git a/src/Data/These.purs b/src/Data/These.purs index 5749fb8..b996589 100644 --- a/src/Data/These.purs +++ b/src/Data/These.purs @@ -174,3 +174,19 @@ isThat = isJust <<< that -- | Returns `true` when the `These` value is `Both` isBoth :: forall a b. These a b -> Boolean isBoth = isJust <<< both + +-- | Swap between `This` and `That`, and flips the order for `Both`. +swap :: forall a b. These a b -> These b a +swap = these That This (flip Both) + +-- | Re-associate `These` from left to right. +assoc :: forall a b c. These (These a b) c -> These a (These b c) +assoc = case _ of + This (This a) -> This a + This (That b) -> That (This b) + This (Both a b) -> Both a (This b) + That c -> That (That c) + Both (This a) c -> Both a (That c) + Both (That b) c -> That (Both b c) + Both (Both a b) c -> Both a (Both b c) + diff --git a/src/Test/QuickCheck/Laws/Data/Align.purs b/src/Test/QuickCheck/Laws/Data/Align.purs new file mode 100644 index 0000000..3b7be26 --- /dev/null +++ b/src/Test/QuickCheck/Laws/Data/Align.purs @@ -0,0 +1,63 @@ +module Test.QuickCheck.Laws.Control.Align where + +import Prelude + +import Data.Align (class Align, align) +import Data.Bifunctor (bimap) +import Data.These (These(..), assoc, swap) +import Effect (Effect) +import Effect.Console (log) +import Test.QuickCheck (quickCheck') +import Test.QuickCheck.Arbitrary (class Arbitrary) +import Test.QuickCheck.Laws (A, B, C, D) +import Type.Proxy (Proxy2) + +-- | Instances are required to satisfy the following laws: +-- | +-- | - Idempotency: `join (align identity) == map (join These)` +-- | - Commutativity `align identity x y == swap <$> align identity y x` +-- | - Associativity `align identity x (align identity y z) == assoc <$> align identity (align identity x y) z` +-- | - Functoriality `align identity (f <$> x) (g <$> y) ≡ bimap f g <$> align identity x y` +checkAlign + :: forall f + . Align f + => Arbitrary (f A) + => Arbitrary (f B) + => Arbitrary (f C) + => Eq (f (These A A)) + => Eq (f (These A B)) + => Eq (f (These C D)) + => Eq (f (These A (These B C))) + => Proxy2 f + -> Effect Unit +checkAlign _ = do + + log "Checking 'Idempotency' law for Align" + quickCheck' 1000 idempotency + + log "Checking 'Commutativity' law for Align" + quickCheck' 1000 commutativity + + log "Checking 'Associativity' law for Align" + quickCheck' 1000 associativity + + log "Checking 'Functoriality' law for Align" + quickCheck' 1000 functoriality + + where + + idempotency :: f A -> Boolean + idempotency fa = join (align identity) fa == map (join Both) fa + + commutativity :: f A -> f B -> Boolean + commutativity fa fb = align identity fa fb == (swap <$> align identity fb fa) + + associativity :: f A -> f B -> f C -> Boolean + associativity fa fb fc = + align identity fa (align identity fb fc) == + (assoc <$> align identity (align identity fa fb) fc) + + functoriality :: f A -> f B -> (A -> C) -> (B -> D) -> Boolean + functoriality a b f g = + align identity (f <$> a) (g <$> b) == + (bimap f g <$> align identity a b) diff --git a/src/Test/QuickCheck/Laws/Data/Alignable.purs b/src/Test/QuickCheck/Laws/Data/Alignable.purs new file mode 100644 index 0000000..b1242ad --- /dev/null +++ b/src/Test/QuickCheck/Laws/Data/Alignable.purs @@ -0,0 +1,39 @@ +module Test.QuickCheck.Laws.Control.Alignable where + +import Prelude + +import Data.Align (class Alignable, align, nil) +import Data.These (These(..)) +import Effect (Effect) +import Effect.Console (log) +import Test.QuickCheck (quickCheck') +import Test.QuickCheck.Arbitrary (class Arbitrary) +import Test.QuickCheck.Laws (A, B) +import Type.Proxy (Proxy2) + +-- | Instances are required to satisfy the following laws: +-- | +-- | - Left Identity: `align identity nil x == fmap That x` +-- | - Right Identity: `align identity x nil ≡ fmap This x` +checkAlignable + :: forall f + . Alignable f + => Arbitrary (f A) + => Arbitrary (f B) + => Eq (f (These A B)) + => Proxy2 f + -> Effect Unit +checkAlignable _ = do + + log "Checking 'Left Identity' law for Alignable" + quickCheck' 1000 leftIdentity + log "Checking 'Right Identity' law for Alignable" + quickCheck' 1000 rightIdentity + + where + + leftIdentity :: f B -> Boolean + leftIdentity fb = align identity (nil :: f A) fb == map That fb + + rightIdentity :: f A -> Boolean + rightIdentity fa = align identity fa (nil :: f B) == map This fa diff --git a/src/Test/QuickCheck/Laws/Data/Crosswalk.purs b/src/Test/QuickCheck/Laws/Data/Crosswalk.purs new file mode 100644 index 0000000..c4462d9 --- /dev/null +++ b/src/Test/QuickCheck/Laws/Data/Crosswalk.purs @@ -0,0 +1,33 @@ +module Test.QuickCheck.Laws.Control.Crosswalk where + +import Prelude + +import Data.Align (class Alignable, class Crosswalk, crosswalk, nil) +import Effect (Effect) +import Effect.Console (log) +import Test.QuickCheck (quickCheck') +import Test.QuickCheck.Arbitrary (class Arbitrary) +import Test.QuickCheck.Laws (A) +import Type.Proxy (Proxy2) + +-- | Instances are required to satisfy the following laws: +-- | +-- | - Annihilation: `crosswalk (const nil) == const nil` +checkCrosswalk + :: forall f t + . Crosswalk f + => Alignable t + => Arbitrary (f A) + => Eq (t (f A)) + => Proxy2 f + -> Proxy2 t + -> Effect Unit +checkCrosswalk _ _ = do + + log "Checking 'Annihilation' law for Crosswalk" + quickCheck' 1000 annihilation + + where + + annihilation :: f A -> Boolean + annihilation fa = crosswalk (const (nil :: t A)) fa == nil diff --git a/test/Main.purs b/test/Main.purs index f91f98c..2b601ac 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -2,10 +2,50 @@ module Test.Main where import Prelude +import Data.Align (class Crosswalk) +import Data.List (List) +import Data.Maybe (Maybe) import Effect (Effect) -import Effect.Class.Console (log) +import Effect.Console (log) +import Test.QuickCheck.Arbitrary (class Arbitrary) +import Test.QuickCheck.Laws (A) +import Test.QuickCheck.Laws.Control.Align (checkAlign) +import Test.QuickCheck.Laws.Control.Alignable (checkAlignable) +import Test.QuickCheck.Laws.Control.Crosswalk (checkCrosswalk) +import Type.Proxy (Proxy2(..)) + +runCrosswalkChecksFor + :: forall f + . Crosswalk f + => Arbitrary (f A) + => Eq (f A) + => Proxy2 f + -> String + -> Effect Unit +runCrosswalkChecksFor p name = do + log $ "Check Crosswalk instance for " <> name <> "/Array" + checkCrosswalk p (Proxy2 :: _ Array) + log $ "Check Crosswalk instance for " <> name <> "/Maybe" + checkCrosswalk p (Proxy2 :: _ Maybe) + log $ "Check Crosswalk instance for " <> name <> "/List" + checkCrosswalk p (Proxy2 :: _ List) main :: Effect Unit main = do - log "🍝" - log "You should add some tests." + log "Checking Align instance for Array" + checkAlign (Proxy2 :: _ Array) + log "Checking Align instance for List" + checkAlign (Proxy2 :: _ List) + log "Checking Align instance for Maybe" + checkAlign (Proxy2 :: _ Maybe) + + log "Check Alignable instance for Array" + checkAlignable (Proxy2 :: _ Array) + log "Checking Alignable instance for List" + checkAlignable (Proxy2 :: _ List) + log "Checking Alignable instance for Maybe" + checkAlignable (Proxy2 :: _ Maybe) + + runCrosswalkChecksFor (Proxy2 :: _ Array) "Array" + runCrosswalkChecksFor (Proxy2 :: _ Maybe) "Maybe" + runCrosswalkChecksFor (Proxy2 :: _ List) "List"