Redefine GAlign to merge into an Alternative context.

src/Data/Align/Generic.hs

@@ -1,10 +1,10 @@
 {-# LANGUAGE DataKinds, DefaultSignatures, TypeOperators, UndecidableInstances #-}
 module Data.Align.Generic where
 
+import Control.Applicative
 import Control.Monad
-import Data.Align
-import Data.Functor.Identity
 import Data.List.NonEmpty (NonEmpty(..))
+import Data.Maybe (fromMaybe)
 import Data.Proxy
 import Data.These
 import Data.Union
@@ -13,49 +13,46 @@ import GHC.Generics
 -- | Functors which can be aligned (structure-unioning-ly zipped). The default implementation will operate generically over the constructors in the aligning type.
 class GAlign f where
   -- | Perform generic alignment of values of some functor, applying the given function to alignments of elements.
-  galignWith :: (These a b -> c) -> f a -> f b -> Maybe (f c)
-  default galignWith :: (Generic1 f, GAlign (Rep1 f)) => (These a b -> c) -> f a -> f b -> Maybe (f c)
+  galignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
+  default galignWith :: (Alternative g, Generic1 f, GAlign (Rep1 f)) => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
   galignWith f a b = to1 <$> galignWith f (from1 a) (from1 b)
 
-galign :: GAlign f => f a -> f b -> Maybe (f (These a b))
-galign = galignWith id
+galign :: (Alternative g, GAlign f) => f a1 -> f a2 -> g (f (These a1 a2))
+galign = galignWith pure
 
 -- 'Data.Align.Align' instances
 
-instance GAlign [] where
-  galignWith = galignWithAlign
 instance GAlign Maybe where
-  galignWith = galignWithAlign
-instance GAlign Identity where
-  galignWith f (Identity a) (Identity b) = Just (Identity (f (These a b)))
+  galignWith f (Just a1) (Just a2) = Just <$> f (These a1 a2)
+  galignWith f (Just a1) Nothing   = Just <$> f (This a1)
+  galignWith f Nothing   (Just a2) = Just <$> f (That a2)
+  galignWith _ Nothing   Nothing   = pure Nothing
 
-instance Apply GAlign fs => GAlign (Union fs) where
-  galignWith f = (join .) . apply2' (Proxy :: Proxy GAlign) (\ inj -> (fmap inj .) . galignWith f)
+instance GAlign [] where
+  galignWith f (a1:as1) (a2:as2) = (:) <$> f (These a1 a2) <*> galignWith f as1 as2
+  galignWith f []       as2      = traverse (f . That) as2
+  galignWith f as1      []       = traverse (f . This) as1
 
 instance GAlign NonEmpty where
-  galignWith f (a:|as) (b:|bs) = Just (f (These a b) :| alignWith f as bs)
+  galignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> galignWith f as1 as2
 
--- | Implements a function suitable for use as the definition of 'galign' for 'Align'able functors.
-galignAlign :: Align f => f a -> f b -> Maybe (f (These a b))
-galignAlign a = Just . align a
-
-galignWithAlign :: Align f => (These a b -> c) -> f a -> f b -> Maybe (f c)
-galignWithAlign f a b = Just (alignWith f a b)
+instance Apply GAlign fs => GAlign (Union fs) where
+  galignWith f = (fromMaybe empty .) . apply2' (Proxy :: Proxy GAlign) (\ inj -> (fmap inj .) . galignWith f)
 
 
 -- Generics
 
 -- | 'GAlign' over unit constructors.
 instance GAlign U1 where
-  galignWith _ _ _ = Just U1
+  galignWith _ _ _ = pure U1
 
 -- | 'GAlign' over parameters.
 instance GAlign Par1 where
-  galignWith f (Par1 a) (Par1 b) = Just (Par1 (f (These a b)))
+  galignWith f (Par1 a) (Par1 b) = Par1 <$> f (These a b)
 
 -- | 'GAlign' over non-parameter fields. Only equal values are aligned.
 instance Eq c => GAlign (K1 i c) where
-  galignWith _ (K1 a) (K1 b) = guard (a == b) >> Just (K1 b)
+  galignWith _ (K1 a) (K1 b) = guard (a == b) *> pure (K1 b)
 
 -- | 'GAlign' over applications over parameters.
 instance GAlign f => GAlign (Rec1 f) where
@@ -70,7 +67,7 @@ instance (GAlign f, GAlign g) => GAlign (f :+: g) where
   galignWith f a b = case (a, b) of
     (L1 a, L1 b) -> L1 <$> galignWith f a b
     (R1 a, R1 b) -> R1 <$> galignWith f a b
-    _ -> Nothing
+    _ -> empty
 
 -- | 'GAlign' over products.
 instance (GAlign f, GAlign g) => GAlign (f :*: g) where

src/Interpreter.hs

@@ -65,9 +65,7 @@ runAlgorithm :: (Diffable syntax, GAlign syntax, Traversable syntax, Alternative
 runAlgorithm comparable eqTerms = go
   where go = iterFreerA (\ step yield -> case step of
           Algorithm.Diff t1 t2 -> (go (algorithmForTerms t1 t2) <|> pure (replacing t1 t2) >>= yield)
-          Linear f1 f2 -> case galignWith (go . diffThese) f1 f2 of
-            Just result -> sequenceA result >>= yield
-            _ -> empty
+          Linear f1 f2 -> galignWith (go . diffThese) f1 f2 >>= yield
           RWS as bs -> traverse (go . diffThese) (rws comparable eqTerms as bs) >>= yield
           Delete a -> yield (deleting a)
           Insert b -> yield (inserting b)
@@ -111,6 +109,6 @@ equivalentTerms t1@(Term (In _ u1)) t2@(Term (In _ u2))
   = equivalentTerms s1 t2
   | Just (Syntax.Context _ s2) <- prj u2
   = equivalentTerms t1 s2
-  | Just aligned <- galignWith (these (const False) (const False) equivalentTerms) u1 u2
+  | Just aligned <- galignWith (Just . these (const False) (const False) equivalentTerms) u1 u2
   = and aligned
   | otherwise = False

src/RWS.hs

@@ -340,7 +340,7 @@ editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDi
           _ | m <= 0 -> 0
           Merge body -> sum (fmap ($ pred m) body)
           body -> succ (sum (fmap ($ pred m) body))
-        approximateDiff a b = maybe (replacing a b) (merge (extract a, extract b)) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b))
+        approximateDiff a b = maybe (replacing a b) (merge (extract a, extract b)) (galignWith (Just . these deleting inserting approximateDiff) (unwrap a) (unwrap b))
 
 
 -- Instances

src/Syntax.hs

@@ -2,7 +2,6 @@
 module Syntax where
 
 import Algorithm
-import Control.Applicative (empty)
 import Data.Aeson (ToJSON, (.=))
 import Data.Align.Generic
 import Data.Foldable (toList)
@@ -165,6 +164,4 @@ instance Diffable Syntax where
       Function <$> diff idA idB
                <*> byRWS paramsA paramsB
                <*> byRWS bodyA bodyB
-    _ -> case galignWith diffThese s1 s2 of
-      Just result -> sequenceA result
-      _ -> empty
+    _ -> galignWith diffThese s1 s2