From 2c9ef549b5c1707a12fb867dbb57d12992e24882 Mon Sep 17 00:00:00 2001
From: mniip <mniip@mniip.com>
Date: Tue, 6 Feb 2024 10:35:20 +0100
Subject: [PATCH] Add Crosswalk instances for: NonEmpty, Proxy, Const,
 Functor.Sum, These1

---
 semialign/src/Data/Crosswalk.hs     | 45 +++++++++++++++++++++++++----
 these-tests/test/Tests/Crosswalk.hs | 17 +++++++++--
 2 files changed, 53 insertions(+), 9 deletions(-)

diff --git a/semialign/src/Data/Crosswalk.hs b/semialign/src/Data/Crosswalk.hs
index df3d54c..30b32a7 100644
--- a/semialign/src/Data/Crosswalk.hs
+++ b/semialign/src/Data/Crosswalk.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE DeriveFunctor #-}
 module Data.Crosswalk (
     -- * Crosswalk
     Crosswalk (..),
@@ -6,15 +7,19 @@ module Data.Crosswalk (
     Bicrosswalk (..),
     ) where
 
-import Control.Applicative   (pure, (<$>))
+import Control.Applicative   (pure, (<$>), Const(..))
 import Data.Bifoldable       (Bifoldable (..))
 import Data.Bifunctor        (Bifunctor (..))
 import Data.Foldable         (Foldable (..))
 import Data.Functor.Compose  (Compose (..))
 import Data.Functor.Identity (Identity (..))
+import Data.Functor.Sum      (Sum (..))
+import Data.Functor.These    (These1 (..))
+import Data.Proxy            (Proxy (..))
 import Data.Vector.Generic   (Vector)
 import Prelude               (Either (..), Functor (fmap), Maybe (..), id, (.))
 
+import qualified Data.List.NonEmpty  as NE
 import qualified Data.Sequence       as Seq
 import qualified Data.Vector         as V
 import qualified Data.Vector.Generic as VG
@@ -55,15 +60,15 @@ instance Crosswalk [] where
     crosswalk f (x:xs) = alignWith cons (f x) (crosswalk f xs)
       where cons = these pure id (:)
 
+instance Crosswalk NE.NonEmpty where
+    crosswalk f (x NE.:| []) = (NE.:| []) <$> f x
+    crosswalk f (x1 NE.:| x2 : xs) = alignWith cons (f x1) (crosswalk f (x2 NE.:| xs))
+      where cons = these (NE.:| []) id (NE.<|)
+
 instance Crosswalk Seq.Seq where
     crosswalk f = foldr (alignWith cons . f) nil where
         cons = these Seq.singleton id (Seq.<|)
 
-instance Crosswalk (These a) where
-    crosswalk _ (This _) = nil
-    crosswalk f (That x) = That <$> f x
-    crosswalk f (These a x) = These a <$> f x
-
 crosswalkVector :: (Vector v a, Vector v b, Align f)
     => (a -> f b) -> v a -> f (v b)
 crosswalkVector f = fmap VG.fromList . VG.foldr (alignWith cons . f) nil where
@@ -72,12 +77,37 @@ crosswalkVector f = fmap VG.fromList . VG.foldr (alignWith cons . f) nil where
 instance Crosswalk V.Vector where
     crosswalk = crosswalkVector
 
+instance Crosswalk (Either e) where
+    crosswalk _ (Left _) = nil
+    crosswalk f (Right x) = Right <$> f x
+
+instance Crosswalk (These a) where
+    crosswalk _ (This _) = nil
+    crosswalk f (That x) = That <$> f x
+    crosswalk f (These a x) = These a <$> f x
+
 instance Crosswalk ((,) a) where
     crosswalk fun (a, x) = fmap ((,) a) (fun x)
 
 -- can't (shouldn't) do longer tuples until there are Functor and Foldable
 -- instances for them
 
+instance Crosswalk Proxy where
+    crosswalk _ _ = nil
+
+instance Crosswalk (Const r) where
+    crosswalk _ _ = nil
+
+instance (Crosswalk f, Crosswalk g) => Crosswalk (Sum f g) where
+    crosswalk f (InL xs) = InL <$> crosswalk f xs
+    crosswalk f (InR xs) = InR <$> crosswalk f xs
+
+instance (Crosswalk f, Crosswalk g) => Crosswalk (These1 f g) where
+    crosswalk f (This1 xs) = This1 <$> crosswalk f xs
+    crosswalk f (That1 ys) = That1 <$> crosswalk f ys
+    crosswalk f (These1 xs ys) = alignWith go (crosswalk f xs) (crosswalk f ys)
+      where go = these This1 That1 These1
+
 instance (Crosswalk f, Crosswalk g) => Crosswalk (Compose f g) where
     crosswalk f
         = fmap Compose -- can't coerce: maybe the Align-able thing has role nominal
@@ -113,3 +143,6 @@ instance Bicrosswalk These where
     bicrosswalk f _ (This x) = This <$> f x
     bicrosswalk _ g (That x) = That <$> g x
     bicrosswalk f g (These x y) = align (f x) (g y)
+
+instance Bicrosswalk Const where
+    bicrosswalk f _ (Const x) = Const <$> f x
diff --git a/these-tests/test/Tests/Crosswalk.hs b/these-tests/test/Tests/Crosswalk.hs
index 6a648f5..55d689e 100644
--- a/these-tests/test/Tests/Crosswalk.hs
+++ b/these-tests/test/Tests/Crosswalk.hs
@@ -3,10 +3,15 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Tests.Crosswalk (crosswalkProps) where
 
+import Control.Applicative           (Const)
 import Control.Monad.Trans.Instances ()
 import Data.Functor.Compose          (Compose (..))
 import Data.Functor.Identity         (Identity (..))
+import Data.Functor.Sum              (Sum)
+import Data.Functor.These            (These1)
+import Data.List.NonEmpty            (NonEmpty)
 import Data.Map                      (Map)
+import Data.Proxy                    (Proxy)
 import Data.Semigroup                (Semigroup (..))
 import Data.Sequence                 (Seq)
 import Data.Typeable                 (Typeable, typeOf1)
@@ -27,13 +32,19 @@ import Tests.Orphans ()
 
 crosswalkProps :: TestTree
 crosswalkProps = testGroup "Crosswalk"
-    [ crosswalkLaws (P :: P [])
+    [ crosswalkLaws (P :: P Identity)
     , crosswalkLaws (P :: P Maybe)
-    , crosswalkLaws (P :: P Identity)
-    , crosswalkLaws (P :: P (These Int))
+    , crosswalkLaws (P :: P [])
+    , crosswalkLaws (P :: P NonEmpty)
     , crosswalkLaws (P :: P Seq)
     , crosswalkLaws (P :: P V.Vector)
+    , crosswalkLaws (P :: P (Either Int))
+    , crosswalkLaws (P :: P (These Int))
     , crosswalkLaws (P :: P ((,) Int))
+    , crosswalkLaws (P :: P Proxy)
+    , crosswalkLaws (P :: P (Const Int))
+    , crosswalkLaws (P :: P (Sum [] []))
+    , crosswalkLaws (P :: P (These1 [] []))
     , crosswalkLaws (P :: P (Compose [] []))
     ]