Add the Align, Alignable and Crosswalk classes

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:
 

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" ]
 }

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
+

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)
+

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)

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

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

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"