From 72574bd836cf4affa80a6de1c8ffada8eefe7557 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 13 Sep 2017 15:59:34 -0400 Subject: [PATCH] =?UTF-8?q?Diffs=20don=E2=80=99t=20need=20let-bindings.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Alignment.hs | 12 +++--- src/Diff.hs | 84 +++++++++---------------------------- src/Interpreter.hs | 9 ++-- src/Renderer/SExpression.hs | 24 +---------- src/Renderer/TOC.hs | 19 ++++----- 5 files changed, 36 insertions(+), 112 deletions(-) diff --git a/src/Alignment.hs b/src/Alignment.hs index 809f5195b..c98b3844d 100644 --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -16,11 +16,11 @@ import Data.Align import Data.Bifunctor.Join import Data.Foldable (toList) import Data.Function (on) -import Data.Functor.Binding (BindingF(..), envLookup) import Data.Functor.Both +import Data.Functor.Foldable (cata) import Data.Functor.Identity import Data.List (partition, sortBy) -import Data.Maybe (catMaybes, fromJust, fromMaybe, listToMaybe) +import Data.Maybe (catMaybes, fromJust, listToMaybe) import Data.Range import Data.Semigroup ((<>)) import Data.Source @@ -47,11 +47,9 @@ hasChanges = or . (True <$) -- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side. alignDiff :: (HasField fields Range, Traversable f) => Both Source -> Diff f (Record fields) -> [Join These (SplitDiff [] (Record fields))] -alignDiff sources = evalDiff $ \ diff env -> case diff of - Let _ body -> case body of - Patch patch -> alignPatch sources patch - Merge (In (ann1, ann2) syntax) -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (In (both ann1 ann2) syntax) - Var v -> fromMaybe [] (envLookup v env) +alignDiff sources = cata $ \ diff -> case diff of + Patch patch -> alignPatch sources patch + Merge (In (ann1, ann2) syntax) -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (In (both ann1 ann2) syntax) -- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff. alignPatch :: forall fields f. (Traversable f, HasField fields Range) => Both Source -> Patch (TermF f (Record fields) [Join These (SplitDiff [] (Record fields))]) -> [Join These (SplitDiff [] (Record fields))] diff --git a/src/Diff.hs b/src/Diff.hs index d09f2f5ba..14b3f082f 100644 --- a/src/Diff.hs +++ b/src/Diff.hs @@ -2,20 +2,15 @@ module Diff where import Data.Aeson -import Control.Monad (join) -import Control.Monad.Effect -import Control.Monad.Effect.Reader import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.Foldable (toList) -import Data.Functor.Binding (BindingF(..), Env(..), Metavar(..), bindings, envExtend, envLookup) import Data.Functor.Classes import Data.Functor.Foldable hiding (fold) import Data.Functor.Identity import Data.Functor.Sum import Data.JSON.Fields -import Data.Maybe (fromMaybe) import Data.Mergeable import Data.Record import Patch @@ -24,7 +19,7 @@ import Term import Text.Show -- | A recursive structure indicating the changed & unchanged portions of a labelled tree. -newtype Diff syntax ann = Diff { unDiff :: BindingF (DiffF syntax ann) (Diff syntax ann) } +newtype Diff syntax ann = Diff { unDiff :: DiffF syntax ann (Diff syntax ann) } -- | A single entry within a recursive 'Diff'. data DiffF syntax ann recur @@ -36,7 +31,7 @@ data DiffF syntax ann recur -- | Constructs a 'Diff' replacing one 'Term' with another recursively. replacing :: Functor syntax => Term syntax ann -> Term syntax ann -> Diff syntax ann -replacing (Term (In a1 r1)) (Term (In a2 r2)) = Diff (Let mempty (Patch (Replace (In a1 (InR (deleting <$> r1))) (In a2 (InR (inserting <$> r2)))))) +replacing (Term (In a1 r1)) (Term (In a2 r2)) = Diff (Patch (Replace (In a1 (InR (deleting <$> r1))) (In a2 (InR (inserting <$> r2))))) -- | Constructs a 'Diff' inserting a 'Term' recursively. inserting :: Functor syntax => Term syntax ann -> Diff syntax ann @@ -44,7 +39,7 @@ inserting = cata insertF -- | Constructs a 'Diff' inserting a single 'TermF' populated by further 'Diff's. insertF :: TermF syntax ann (Diff syntax ann) -> Diff syntax ann -insertF = Diff . Let mempty . Patch . Insert . hoistTermF InR +insertF = Diff . Patch . Insert . hoistTermF InR -- | Constructs a 'Diff' deleting a 'Term' recursively. deleting :: Functor syntax => Term syntax ann -> Diff syntax ann @@ -52,42 +47,20 @@ deleting = cata deleteF -- | Constructs a 'Diff' deleting a single 'TermF' populated by further 'Diff's. deleteF :: TermF syntax ann (Diff syntax ann) -> Diff syntax ann -deleteF = Diff . Let mempty . Patch . Delete . hoistTermF InR +deleteF = Diff . Patch . Delete . hoistTermF InR -- | Constructs a 'Diff' merging two annotations for a single syntax functor populated by further 'Diff's. merge :: (ann, ann) -> syntax (Diff syntax ann) -> Diff syntax ann -merge = (Diff .) . (Let mempty .) . (Merge .) . In - --- | Constructs a 'Diff' referencing the specified variable. This should only ever be used in the body of 'letBind' in order to avoid accidentally shadowing bound variables in a diff. -var :: Metavar -> Diff syntax ann -var = Diff . Var +merge = (Diff .) . (Merge .) . In type SyntaxDiff fields = Diff Syntax (Record fields) -evalDiff :: Functor syntax => (BindingF (DiffF syntax ann) a -> Env a -> a) -> Diff syntax ann -> a -evalDiff algebra = evalDiffR (\ diff env -> algebra (snd <$> diff) (snd <$> env)) - -evalDiffR :: Functor syntax => (BindingF (DiffF syntax ann) (Diff syntax ann, a) -> Env (Diff syntax ann, a) -> a) -> Diff syntax ann -> a -evalDiffR algebra = flip (para evalBinding) mempty - where evalBinding bind env = case bind of - Let vars body -> - let evaluated = second ($ env) <$> vars - extended = foldr (uncurry envExtend) env (unEnv evaluated) - in algebra (Let evaluated (second ($ extended) <$> body)) env - _ -> algebra (second ($ env) <$> bind) env - -evalDiffRM :: (Functor syntax, Reader (Env (Diff syntax ann, Eff fs a)) :< fs) => (BindingF (DiffF syntax ann) (Diff syntax ann, Eff fs a) -> Eff fs a) -> Diff syntax ann -> Eff fs a -evalDiffRM algebra = para (\ diff -> local (bindMetavariables diff) (algebra diff)) - where bindMetavariables diff env = foldr (uncurry envExtend) env (unEnv (bindings diff)) - - diffSum :: (Foldable syntax, Functor syntax) => (forall a. Patch a -> Int) -> Diff syntax ann -> Int -diffSum patchCost = evalDiff $ \ diff env -> case diff of - Let _ (Patch patch) -> patchCost patch + sum (sum <$> patch) - Let _ (Merge merge) -> sum merge - Var v -> fromMaybe 0 (envLookup v env) +diffSum patchCost = cata $ \ diff -> case diff of + Patch patch -> patchCost patch + sum (sum <$> patch) + Merge merge -> sum merge -- | The sum of the node count of the diff’s patches. diffCost :: (Foldable syntax, Functor syntax) => Diff syntax ann -> Int @@ -96,21 +69,18 @@ diffCost = diffSum (const 1) diffPatch :: Diff syntax ann -> Maybe (Patch (TermF (Sum Identity syntax) ann (Diff syntax ann))) diffPatch diff = case unDiff diff of - Let _ (Patch patch) -> Just patch + Patch patch -> Just patch _ -> Nothing diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann -> [Patch (TermF (Sum Identity syntax) ann (Diff syntax ann))] -diffPatches = evalDiffR $ \ diff env -> case diff of - Let _ (Patch patch) -> fmap (fmap fst) patch : foldMap (foldMap (toList . diffPatch . fst)) patch - Let _ (Merge merge) -> foldMap (toList . diffPatch . fst) merge - Var var -> maybe [] snd (envLookup var env) +diffPatches = para $ \ diff -> case diff of + Patch patch -> fmap (fmap fst) patch : foldMap (foldMap (toList . diffPatch . fst)) patch + Merge merge -> foldMap (toList . diffPatch . fst) merge -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch. mergeMaybe :: (Mergeable syntax, Traversable syntax) => (DiffF syntax ann (Maybe (Term syntax ann)) -> Maybe (Term syntax ann)) -> Diff syntax ann -> Maybe (Term syntax ann) -mergeMaybe algebra = evalDiff $ \ bind env -> case bind of - Let _ diff -> algebra diff - Var v -> join (envLookup v env) +mergeMaybe = cata -- | Recover the before state of a diff. beforeTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann -> Maybe (Term syntax ann) @@ -136,18 +106,14 @@ stripDiff :: Functor f stripDiff = fmap rtail -type instance Base (Diff syntax ann) = BindingF (DiffF syntax ann) +type instance Base (Diff syntax ann) = DiffF syntax ann instance Functor syntax => Recursive (Diff syntax ann) where project = unDiff instance Functor syntax => Corecursive (Diff syntax ann) where embed = Diff instance Eq1 f => Eq1 (Diff f) where - liftEq eqA = go - where go (Diff d1) (Diff d2) = eq' d1 d2 - eq' (Let v1 b1) (Let v2 b2) = liftEq go v1 v2 && liftEq2 eqA go b1 b2 - eq' (Var v1) (Var v2) = v1 == v2 - eq' _ _ = False + liftEq eqA = go where go (Diff d1) (Diff d2) = liftEq2 eqA go d1 d2 instance (Eq1 f, Eq a) => Eq (Diff f a) where (==) = eq1 @@ -166,10 +132,7 @@ instance (Eq1 f, Eq a, Eq b) => Eq (DiffF f a b) where instance Show1 f => Show1 (Diff f) where - liftShowsPrec sp sl = go - where go d = showsUnaryWith showsPrec' "Diff" d . unDiff - showsPrec' d (Let vars body) = showsBinaryWith (liftShowsPrec go (showListWith (go 0))) (liftShowsPrec2 sp sl go (showListWith (go 0))) "Let" d vars body - showsPrec' d (Var var) = showsUnaryWith showsPrec "Var" d var + liftShowsPrec sp sl = go where go d = showsUnaryWith (liftShowsPrec2 sp sl go (showListWith (go 0))) "Diff" d . unDiff instance (Show1 f, Show a) => Show (Diff f a) where showsPrec = showsPrec1 @@ -189,22 +152,13 @@ instance (Show1 f, Show a, Show b) => Show (DiffF f a b) where instance Functor f => Functor (Diff f) where - fmap f = go - where go = Diff . fmap' . unDiff - fmap' (Let vars body) = Let (fmap go vars) (bimap f go body) - fmap' (Var var) = Var var + fmap f = go where go = Diff . bimap f go . unDiff instance Foldable f => Foldable (Diff f) where - foldMap f = go - where go = foldMap' . unDiff - foldMap' (Let vars body) = foldMap go vars `mappend` bifoldMap f go body - foldMap' _ = mempty + foldMap f = go where go = bifoldMap f go . unDiff instance Traversable f => Traversable (Diff f) where - traverse f = go - where go = fmap Diff . traverse' . unDiff - traverse' (Let vars body) = Let <$> traverse go vars <*> bitraverse f go body - traverse' (Var v) = pure (Var v) + traverse f = go where go = fmap Diff . bitraverse f go . unDiff instance Functor syntax => Bifunctor (DiffF syntax) where diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9ed46840b..b6525c24d 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -9,8 +9,8 @@ module Interpreter import Algorithm import Control.Monad.Free.Freer import Data.Align.Generic -import Data.Functor.Binding (BindingF(..), envLookup) import Data.Functor.Both +import Data.Functor.Foldable (cata) import Data.Functor.Classes (Eq1) import Data.Hashable (Hashable) import Data.Maybe (isJust) @@ -124,9 +124,8 @@ defaultM = 10 -- | Computes a constant-time approximation to the edit distance of a diff. This is done by comparing at most _m_ nodes, & assuming the rest are zero-cost. editDistanceUpTo :: (GAlign f, Foldable f, Functor f) => Integer -> These (Term f (Record fields)) (Term f (Record fields)) -> Int editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDiff a b)) - where diffCost = flip . evalDiff $ \ diff env m -> case diff of + where diffCost = flip . cata $ \ diff m -> case diff of _ | m <= 0 -> 0 - Let _ (Merge body) -> sum (fmap ($ pred m) body) - Let _ body -> succ (sum (fmap ($ pred m) body)) - Var v -> maybe 0 ($ pred m) (envLookup v env) + 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)) diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index e5b098e19..7f0a8cf8f 100644 --- a/src/Renderer/SExpression.hs +++ b/src/Renderer/SExpression.hs @@ -4,12 +4,8 @@ module Renderer.SExpression , renderSExpressionTerm ) where -import Data.Bifunctor (bimap) import Data.ByteString.Char8 hiding (intersperse, foldr, spanEnd, length, null) -import Data.Foldable (fold) -import Data.Functor.Binding (BindingF(..), Env(..), Metavar(..)) import Data.Functor.Foldable (cata) -import Data.List (intersperse) import Data.Record import Data.Semigroup import Diff @@ -19,18 +15,12 @@ import Term -- | Returns a ByteString SExpression formatted diff. renderSExpressionDiff :: (ConstrainAll Show fields, Foldable f, Functor f) => Diff f (Record fields) -> ByteString -renderSExpressionDiff diff = cata printBindingF diff 0 <> "\n" +renderSExpressionDiff diff = cata printDiffF diff 0 <> "\n" -- | Returns a ByteString SExpression formatted term. renderSExpressionTerm :: (ConstrainAll Show fields, Foldable f, Functor f) => Term f (Record fields) -> ByteString renderSExpressionTerm term = cata (\ term n -> nl n <> replicate (2 * n) ' ' <> printTermF term n) term 0 <> "\n" -printBindingF :: (ConstrainAll Show fields, Foldable f, Functor f) => BindingF (DiffF f (Record fields)) (Int -> ByteString) -> Int -> ByteString -printBindingF bind n = case bind of - Let vars body | null vars -> printDiffF body n - | otherwise -> nl n <> pad n <> showBindings (($ n) <$> vars) <> printDiffF body n - Var v -> nl n <> pad n <> showMetavar v - printDiffF :: (ConstrainAll Show fields, Foldable f, Functor f) => DiffF f (Record fields) (Int -> ByteString) -> Int -> ByteString printDiffF diff n = case diff of Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> printTermF term n <> "-}" @@ -54,15 +44,3 @@ showAnnotation :: ConstrainAll Show fields => Record fields -> ByteString showAnnotation Nil = "" showAnnotation (only :. Nil) = pack (show only) showAnnotation (first :. rest) = pack (show first) <> " " <> showAnnotation rest - -showBindings :: Env ByteString -> ByteString -showBindings (Env []) = "" -showBindings (Env bindings) = "[ " <> fold (intersperse "\n, " (showBinding <$> bindings)) <> " ]" - where showBinding (var, val) = showMetavar var <> "/" <> val - -showMetavar :: Metavar -> ByteString -showMetavar (Metavar i) = pack (toName i) - where toName i | i < 0 = "" - | otherwise = uncurry (++) (bimap (toName . pred) (pure . (alphabet !!)) (i `divMod` la)) - alphabet = ['a'..'z'] - la = length alphabet diff --git a/src/Renderer/TOC.hs b/src/Renderer/TOC.hs index 7d703e742..671661c7f 100644 --- a/src/Renderer/TOC.hs +++ b/src/Renderer/TOC.hs @@ -17,7 +17,6 @@ module Renderer.TOC , entrySummary ) where -import Control.Monad (join) import Data.Aeson import Data.Align (crosswalk) import Data.Bifunctor (bimap) @@ -25,7 +24,6 @@ import Data.Blob import Data.ByteString.Lazy (toStrict) import Data.Error as Error (formatError) import Data.Foldable (fold, foldl', toList) -import Data.Functor.Binding (BindingF(..), envLookup) import Data.Functor.Both hiding (fst, snd) import Data.Functor.Foldable (cata) import Data.Functor.Sum @@ -152,17 +150,14 @@ tableOfContentsBy :: (Foldable f, Functor f) => (forall b. TermF f annotation b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe. -> Diff f annotation -- ^ The diff to compute the table of contents for. -> [Entry a] -- ^ A list of entries for relevant changed and unchanged nodes in the diff. -tableOfContentsBy selector = fromMaybe [] . evalDiff diffAlgebra - where diffAlgebra r env = case r of - Let _ body -> case body of - Patch patch -> (pure . patchEntry <$> crosswalk recur patch) <> foldMap fold patch <> Just [] - Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of - (Just a, Nothing) -> Just [Unchanged a] - (Just a, Just []) -> Just [Changed a] - (_ , entries) -> entries - Var v -> join (envLookup v env) +tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of + Patch patch -> (pure . patchEntry <$> crosswalk recur patch) <> foldMap fold patch <> Just [] + Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of + (Just a, Nothing) -> Just [Unchanged a] + (Just a, Just []) -> Just [Changed a] + (_ , entries) -> entries) - recur (In a (InR s)) = selector (In a s) + where recur (In a (InR s)) = selector (In a s) recur _ = Nothing patchEntry = these Deleted Inserted (const Replaced) . unPatch