From 528728d01c09892c71165935cdb5fc8ee458a2ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Sep 2017 23:02:08 -0400 Subject: [PATCH] Redefine GAlign to merge into an Alternative context. --- src/Data/Align/Generic.hs | 45 ++++++++++++++++++--------------------- src/Interpreter.hs | 6 ++---- src/RWS.hs | 2 +- src/Syntax.hs | 5 +---- 4 files changed, 25 insertions(+), 33 deletions(-) diff --git a/src/Data/Align/Generic.hs b/src/Data/Align/Generic.hs index 101dbeaaa..8f285889f 100644 --- a/src/Data/Align/Generic.hs +++ b/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 diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 08b1fe43c..17cf4a2ca 100644 --- a/src/Interpreter.hs +++ b/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 diff --git a/src/RWS.hs b/src/RWS.hs index 4d7b8755a..f9cdb9779 100644 --- a/src/RWS.hs +++ b/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 diff --git a/src/Syntax.hs b/src/Syntax.hs index 6e9e28795..76b719215 100644 --- a/src/Syntax.hs +++ b/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