Add Crosswalk instances for: NonEmpty, Proxy, Const, Functor.Sum, MaybeT, These1

Author: mniip

semialign/src/Data/Crosswalk.hs

@@ -1,20 +1,27 @@
 {-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE DeriveFunctor #-}
 module Data.Crosswalk (
     -- * Crosswalk
     Crosswalk (..),
     -- * Bicrosswalk
     Bicrosswalk (..),
     ) where
 
-import Control.Applicative   (pure, (<$>))
-import Data.Bifoldable       (Bifoldable (..))
-import Data.Bifunctor        (Bifunctor (..))
-import Data.Foldable         (Foldable (..))
-import Data.Functor.Compose  (Compose (..))
-import Data.Functor.Identity (Identity (..))
-import Data.Vector.Generic   (Vector)
-import Prelude               (Either (..), Functor (fmap), Maybe (..), id, (.))
-
+import Control.Applicative       (Applicative (pure, (<*>)), (<$>), Const(..))
+import Control.Monad.Trans.Maybe (MaybeT (..))
+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.Traversable          (Traversable (traverse))
+import Data.Vector.Generic       (Vector)
+import Prelude                   (Either (..), Functor (fmap), Maybe (..), id, (.), uncurry, maybe)
+
+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 +62,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,18 +79,55 @@ 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
         . crosswalk (crosswalk f)
         . getCompose
 
+data Fill f a = Fill a (f a)
+  deriving (Functor)
+
+instance Align f => Applicative (Fill f) where
+    pure x = Fill x nil
+    Fill deff fs <*> Fill defx xs
+      = Fill (deff defx) (alignWith (uncurry id . fromThese deff defx) fs xs)
+
+instance Traversable t => Crosswalk (MaybeT t) where
+    crosswalk f (MaybeT xs) = case traverse go xs of Fill _ ys -> MaybeT <$> ys
+      where go mx = Fill Nothing (Just <$> maybe nil f mx)
+
 -- --------------------------------------------------------------------------
 -- | Bifoldable bifunctors supporting traversal through an alignable
 --   functor.
@@ -113,3 +157,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

these-tests/test/Tests/Crosswalk.hs

@@ -3,10 +3,16 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Tests.Crosswalk (crosswalkProps) where
 
+import Control.Applicative           (Const)
 import Control.Monad.Trans.Instances ()
+import Control.Monad.Trans.Maybe     (MaybeT)
 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,14 +33,21 @@ 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 [] []))
+    , crosswalkLaws (P :: P (MaybeT []))
     ]
 
 -------------------------------------------------------------------------------