2017-07-21 00:15:01 +03:00
|
|
|
|
{-# LANGUAGE DataKinds, DefaultSignatures, GADTs, RankNTypes, TypeOperators #-}
|
2015-11-18 03:20:52 +03:00
|
|
|
|
module Algorithm where
|
2015-11-18 03:24:01 +03:00
|
|
|
|
|
2017-07-28 21:37:02 +03:00
|
|
|
|
import Control.Applicative (liftA2)
|
2017-08-05 01:49:21 +03:00
|
|
|
|
import Control.Monad (guard, join)
|
2017-09-09 13:23:57 +03:00
|
|
|
|
import Control.Monad.Free.Freer
|
2017-07-28 21:37:02 +03:00
|
|
|
|
import Data.Function (on)
|
2017-06-13 21:49:22 +03:00
|
|
|
|
import Data.Functor.Classes
|
2017-08-14 23:42:13 +03:00
|
|
|
|
import Data.List.NonEmpty (NonEmpty(..))
|
2017-07-28 21:37:02 +03:00
|
|
|
|
import Data.Maybe
|
2017-08-05 01:49:21 +03:00
|
|
|
|
import Data.Proxy
|
2017-02-23 20:25:45 +03:00
|
|
|
|
import Data.These
|
2017-07-21 00:15:01 +03:00
|
|
|
|
import Data.Union
|
|
|
|
|
import Diff
|
|
|
|
|
import GHC.Generics
|
|
|
|
|
import Term
|
2016-08-04 01:12:31 +03:00
|
|
|
|
|
2017-02-21 18:26:27 +03:00
|
|
|
|
-- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm.
|
2017-02-21 18:25:25 +03:00
|
|
|
|
data AlgorithmF term diff result where
|
2017-02-23 20:24:31 +03:00
|
|
|
|
-- | Diff two terms with the choice of algorithm left to the interpreter’s discretion.
|
|
|
|
|
Diff :: term -> term -> AlgorithmF term diff diff
|
2017-02-21 18:38:10 +03:00
|
|
|
|
-- | Diff two terms recursively in O(n) time, resulting in a single diff node.
|
2017-02-21 18:46:19 +03:00
|
|
|
|
Linear :: term -> term -> AlgorithmF term diff diff
|
2017-02-21 18:38:10 +03:00
|
|
|
|
-- | Diff two lists of terms by each element’s similarity in O(n³ log n), resulting in a list of diffs.
|
2017-02-21 18:46:19 +03:00
|
|
|
|
RWS :: [term] -> [term] -> AlgorithmF term diff [diff]
|
2017-02-21 19:40:13 +03:00
|
|
|
|
-- | Delete a term..
|
|
|
|
|
Delete :: term -> AlgorithmF term diff diff
|
|
|
|
|
-- | Insert a term.
|
|
|
|
|
Insert :: term -> AlgorithmF term diff diff
|
|
|
|
|
-- | Replace one term with another.
|
|
|
|
|
Replace :: term -> term -> AlgorithmF term diff diff
|
2015-11-18 03:24:01 +03:00
|
|
|
|
|
2016-09-25 09:50:49 +03:00
|
|
|
|
-- | The free applicative for 'AlgorithmF'. This enables us to construct diff values using <$> and <*> notation.
|
2017-02-24 21:28:44 +03:00
|
|
|
|
type Algorithm term diff = Freer (AlgorithmF term diff)
|
2017-02-21 18:44:48 +03:00
|
|
|
|
|
2016-08-04 19:08:34 +03:00
|
|
|
|
|
|
|
|
|
-- DSL
|
|
|
|
|
|
2017-02-23 20:24:31 +03:00
|
|
|
|
-- | Diff two terms without specifying the algorithm to be used.
|
|
|
|
|
diff :: term -> term -> Algorithm term diff diff
|
2017-09-09 13:23:57 +03:00
|
|
|
|
diff = (liftF .) . Algorithm.Diff
|
2017-02-23 20:24:31 +03:00
|
|
|
|
|
2017-02-23 20:30:26 +03:00
|
|
|
|
-- | Diff a These of terms without specifying the algorithm to be used.
|
2017-02-23 20:25:45 +03:00
|
|
|
|
diffThese :: These term term -> Algorithm term diff diff
|
|
|
|
|
diffThese = these byDeleting byInserting diff
|
|
|
|
|
|
2017-05-03 23:56:15 +03:00
|
|
|
|
-- | Diff a pair of optional terms without specifying the algorithm to be used.
|
|
|
|
|
diffMaybe :: Maybe term -> Maybe term -> Algorithm term diff (Maybe diff)
|
|
|
|
|
diffMaybe a b = case (a, b) of
|
|
|
|
|
(Just a, Just b) -> Just <$> diff a b
|
|
|
|
|
(Just a, _) -> Just <$> byDeleting a
|
|
|
|
|
(_, Just b) -> Just <$> byInserting b
|
|
|
|
|
_ -> pure Nothing
|
|
|
|
|
|
2017-02-21 19:39:41 +03:00
|
|
|
|
-- | Diff two terms linearly.
|
2017-02-21 18:46:19 +03:00
|
|
|
|
linearly :: term -> term -> Algorithm term diff diff
|
2017-02-24 21:28:44 +03:00
|
|
|
|
linearly a b = liftF (Linear a b)
|
2016-08-04 01:38:35 +03:00
|
|
|
|
|
2017-02-21 19:39:41 +03:00
|
|
|
|
-- | Diff two terms using RWS.
|
2017-02-21 18:46:19 +03:00
|
|
|
|
byRWS :: [term] -> [term] -> Algorithm term diff [diff]
|
2017-02-24 21:28:44 +03:00
|
|
|
|
byRWS a b = liftF (RWS a b)
|
2017-02-21 19:40:13 +03:00
|
|
|
|
|
|
|
|
|
-- | Delete a term.
|
|
|
|
|
byDeleting :: term -> Algorithm term diff diff
|
2017-02-24 21:28:44 +03:00
|
|
|
|
byDeleting = liftF . Delete
|
2017-02-21 19:40:13 +03:00
|
|
|
|
|
|
|
|
|
-- | Insert a term.
|
|
|
|
|
byInserting :: term -> Algorithm term diff diff
|
2017-02-24 21:28:44 +03:00
|
|
|
|
byInserting = liftF . Insert
|
2017-02-21 19:40:13 +03:00
|
|
|
|
|
|
|
|
|
-- | Replace one term with another.
|
|
|
|
|
byReplacing :: term -> term -> Algorithm term diff diff
|
2017-02-24 21:28:44 +03:00
|
|
|
|
byReplacing = (liftF .) . Replace
|
2017-06-13 21:49:22 +03:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
instance Show term => Show1 (AlgorithmF term diff) where
|
|
|
|
|
liftShowsPrec _ _ d algorithm = case algorithm of
|
2017-09-09 13:23:57 +03:00
|
|
|
|
Algorithm.Diff t1 t2 -> showsBinaryWith showsPrec showsPrec "Diff" d t1 t2
|
2017-06-13 21:49:22 +03:00
|
|
|
|
Linear t1 t2 -> showsBinaryWith showsPrec showsPrec "Linear" d t1 t2
|
|
|
|
|
RWS as bs -> showsBinaryWith showsPrec showsPrec "RWS" d as bs
|
|
|
|
|
Delete t1 -> showsUnaryWith showsPrec "Delete" d t1
|
|
|
|
|
Insert t2 -> showsUnaryWith showsPrec "Insert" d t2
|
|
|
|
|
Replace t1 t2 -> showsBinaryWith showsPrec showsPrec "Replace" d t1 t2
|
2017-07-21 00:15:01 +03:00
|
|
|
|
|
|
|
|
|
|
2017-07-21 03:21:20 +03:00
|
|
|
|
-- | Diff two terms based on their generic Diffable instances. If the terms are not diffable
|
|
|
|
|
-- (represented by a Nothing diff returned from algorithmFor) replace one term with another.
|
2017-07-21 00:15:01 +03:00
|
|
|
|
algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f a) (Diff f a) (Diff f a)
|
2017-09-12 17:49:37 +03:00
|
|
|
|
algorithmForTerms t1@(Term (In ann1 f1)) t2@(Term (In ann2 f2)) = fromMaybe (byReplacing t1 t2) (fmap (merge (ann1, ann2)) <$> algorithmFor f1 f2)
|
2017-07-21 00:15:01 +03:00
|
|
|
|
|
2017-07-21 03:21:20 +03:00
|
|
|
|
|
|
|
|
|
-- | A type class for determining what algorithm to use for diffing two terms.
|
2017-07-21 00:15:01 +03:00
|
|
|
|
class Diffable f where
|
|
|
|
|
algorithmFor :: f term -> f term -> Maybe (Algorithm term diff (f diff))
|
|
|
|
|
default algorithmFor :: (Generic1 f, Diffable' (Rep1 f)) => f term -> f term -> Maybe (Algorithm term diff (f diff))
|
|
|
|
|
algorithmFor a b = fmap to1 <$> algorithmFor' (from1 a) (from1 b)
|
|
|
|
|
|
2017-07-21 03:25:27 +03:00
|
|
|
|
-- | Diff a Union of Syntax terms. Left is the "rest" of the Syntax terms in the Union,
|
2017-07-21 20:50:53 +03:00
|
|
|
|
-- Right is the "head" of the Union. 'weaken' relaxes the Union to allow the possible
|
|
|
|
|
-- diff terms from the "rest" of the Union, and 'inj' adds the diff terms into the Union.
|
2017-07-21 03:21:20 +03:00
|
|
|
|
-- NB: If Left or Right Syntax terms in our Union don't match, we fail fast by returning Nothing.
|
2017-08-05 01:49:21 +03:00
|
|
|
|
instance Apply1 Diffable fs => Diffable (Union fs) where
|
|
|
|
|
algorithmFor u1 u2 = join (apply1_2' (Proxy :: Proxy Diffable) (\ reinj f1 f2 -> fmap reinj <$> algorithmFor f1 f2) u1 u2)
|
2017-07-21 00:15:01 +03:00
|
|
|
|
|
2017-07-21 20:50:24 +03:00
|
|
|
|
-- | Diff two list parameters using RWS.
|
|
|
|
|
instance Diffable [] where
|
|
|
|
|
algorithmFor a b = Just (byRWS a b)
|
|
|
|
|
|
2017-07-21 03:21:20 +03:00
|
|
|
|
-- | A generic type class for diffing two terms defined by the Generic1 interface.
|
2017-07-21 00:15:01 +03:00
|
|
|
|
class Diffable' f where
|
|
|
|
|
algorithmFor' :: f term -> f term -> Maybe (Algorithm term diff (f diff))
|
|
|
|
|
|
2017-07-21 20:50:53 +03:00
|
|
|
|
-- | Diff two constructors (M1 is the Generic1 newtype for meta-information (possibly related to type constructors, record selectors, and data types))
|
2017-07-21 00:15:01 +03:00
|
|
|
|
instance Diffable' f => Diffable' (M1 i c f) where
|
|
|
|
|
algorithmFor' (M1 a) (M1 b) = fmap M1 <$> algorithmFor' a b
|
|
|
|
|
|
2017-07-21 20:50:53 +03:00
|
|
|
|
-- | Diff the fields of a product type.
|
|
|
|
|
-- i.e. data Foo a b = Foo a b (the 'Foo a b' is captured by 'a :*: b').
|
2017-07-21 00:15:01 +03:00
|
|
|
|
instance (Diffable' f, Diffable' g) => Diffable' (f :*: g) where
|
|
|
|
|
algorithmFor' (a1 :*: b1) (a2 :*: b2) = liftA2 (:*:) <$> algorithmFor' a1 a2 <*> algorithmFor' b1 b2
|
|
|
|
|
|
2017-07-21 20:50:53 +03:00
|
|
|
|
-- | Diff the constructors of a sum type.
|
|
|
|
|
-- i.e. data Foo a = Foo a | Bar a (the 'Foo a' is captured by L1 and 'Bar a' is R1).
|
2017-07-21 00:15:01 +03:00
|
|
|
|
instance (Diffable' f, Diffable' g) => Diffable' (f :+: g) where
|
|
|
|
|
algorithmFor' (L1 a) (L1 b) = fmap L1 <$> algorithmFor' a b
|
|
|
|
|
algorithmFor' (R1 a) (R1 b) = fmap R1 <$> algorithmFor' a b
|
|
|
|
|
algorithmFor' _ _ = Nothing
|
|
|
|
|
|
2017-07-21 03:21:20 +03:00
|
|
|
|
-- | Diff two parameters (Par1 is the Generic1 newtype representing a type parameter).
|
2017-07-21 20:50:53 +03:00
|
|
|
|
-- i.e. data Foo a = Foo a (the 'a' is captured by Par1).
|
2017-07-21 00:15:01 +03:00
|
|
|
|
instance Diffable' Par1 where
|
|
|
|
|
algorithmFor' (Par1 a) (Par1 b) = Just (Par1 <$> linearly a b)
|
|
|
|
|
|
2017-07-21 03:21:20 +03:00
|
|
|
|
-- | Diff two constant parameters (K1 is the Generic1 newtype representing type parameter constants).
|
2017-07-21 20:50:53 +03:00
|
|
|
|
-- i.e. data Foo = Foo Int (the 'Int' is a constant parameter).
|
2017-07-21 00:15:01 +03:00
|
|
|
|
instance Eq c => Diffable' (K1 i c) where
|
|
|
|
|
algorithmFor' (K1 a) (K1 b) = guard (a == b) *> Just (pure (K1 a))
|
|
|
|
|
|
2017-07-21 03:21:20 +03:00
|
|
|
|
-- | Diff two terms whose constructors contain 0 type parameters.
|
|
|
|
|
-- i.e. data Foo = Foo.
|
2017-07-21 00:15:01 +03:00
|
|
|
|
instance Diffable' U1 where
|
|
|
|
|
algorithmFor' _ _ = Just (pure U1)
|
|
|
|
|
|
2017-08-14 23:39:48 +03:00
|
|
|
|
-- | Diff two lists of parameters.
|
2017-07-21 00:15:01 +03:00
|
|
|
|
instance Diffable' (Rec1 []) where
|
|
|
|
|
algorithmFor' a b = fmap Rec1 <$> Just ((byRWS `on` unRec1) a b)
|
2017-08-14 23:42:13 +03:00
|
|
|
|
|
|
|
|
|
-- | Diff two non-empty lists of parameters.
|
|
|
|
|
instance Diffable' (Rec1 NonEmpty) where
|
|
|
|
|
algorithmFor' (Rec1 (a:|as)) (Rec1 (b:|bs)) = Just $ do
|
|
|
|
|
d:ds <- byRWS (a:as) (b:bs)
|
|
|
|
|
pure (Rec1 (d :| ds))
|