github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-22 14:21:31 +03:00
Code Issues Projects Releases Wiki Activity

Copy holds a TermF.

Browse Source
This commit is contained in:
Rob Rix 2017-09-10 19:40:48 +01:00
parent 1ccff72b08
commit 90496bdc1c
5 changed files with 21 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Alignment.hs
View File

@ -47,7 +47,7 @@ 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
Copy _ ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (ann :< r)
Copy _ body -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources body
Var v -> fromMaybe [] (envLookup v env)
Patch patch -> alignPatch sources patch

34
src/Diff.hs
View File

@ -9,7 +9,7 @@ import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.Foldable (fold)
import Data.Functor.Both (Both, Join(..), liftShowsPrecBoth)
import Data.Functor.Both (Both)
import qualified Data.Functor.Both as Both
import Data.Functor.Classes
import Data.Functor.Classes.Pretty.Generic as Pretty
@ -29,7 +29,7 @@ import Text.Show
newtype Diff syntax ann = Diff { unDiff :: DiffF syntax ann (Diff syntax ann) }
data DiffF syntax ann recur
= Copy [(Metavar, recur)] (Both ann) (syntax recur)
= Copy [(Metavar, recur)] (TermF syntax (Both ann) recur)
| Var Metavar
| Patch (Patch (TermF syntax ann recur))
deriving (Foldable, Functor, Traversable)
@ -37,7 +37,7 @@ data DiffF syntax ann recur
type SyntaxDiff fields = Diff Syntax (Record fields)
diffFBindings :: DiffF syntax ann recur -> [(Metavar, recur)]
diffFBindings (Copy bindings _ _) = bindings
diffFBindings (Copy bindings _) = bindings
diffFBindings _ = []
@ -48,7 +48,7 @@ newtype Metavar = Metavar { unMetavar :: Int }
freeMetavariables :: (Foldable syntax, Functor syntax) => Diff syntax ann -> Set.Set Metavar
freeMetavariables = cata $ \ diff -> case diff of
Copy bindings _ body -> foldMap snd bindings <> foldr Set.delete (fold body) (fst <$> bindings)
Copy bindings body -> foldMap snd bindings <> foldr Set.delete (fold body) (fst <$> bindings)
Var v -> Set.singleton v
Patch patch -> foldMap fold patch
@ -69,10 +69,10 @@ evalDiff algebra = evalDiffR (\ diff env -> algebra (snd <$> diff) (snd <$> env)
evalDiffR :: Functor syntax => (DiffF syntax ann (Diff syntax ann, a) -> Env (Diff syntax ann, a) -> a) -> Diff syntax ann -> a
evalDiffR algebra = flip go mempty
where go = para $ \ diff env -> case diff of
Copy bindings ann syntax ->
Copy bindings body ->
let evaluated = fmap (second ($ env)) <$> bindings
extended = foldr (uncurry envExtend) env evaluated
in algebra (Copy evaluated ann (second ($ extended) <$> syntax)) env
in algebra (Copy evaluated (second ($ extended) <$> body)) env
_ -> algebra (second ($ env) <$> diff) env
evalDiffRM :: (Functor syntax, Reader (Env (Diff syntax ann, Eff fs a)) :< fs) => (DiffF syntax ann (Diff syntax ann, Eff fs a) -> Eff fs a) -> Diff syntax ann -> Eff fs a
@ -82,7 +82,7 @@ evalDiffRM algebra = para (\ diff -> local (bindMetavariables diff) (algebra dif
diffSum :: (Foldable syntax, Functor syntax) => (forall a. Patch a -> Int) -> Diff syntax ann -> Int
diffSum patchCost = evalDiff $ \ diff env -> case diff of
Copy _ _ syntax -> sum syntax
Copy _ body -> sum body
Var v -> fromMaybe 0 (envLookup v env)
Patch p -> patchCost p + sum (sum <$> p)
@ -92,14 +92,14 @@ diffCost = diffSum (const 1)
diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann -> [Patch (TermF syntax ann (Diff syntax ann))]
diffPatches = evalDiffR $ \ diff env -> case diff of
Copy _ _ r -> foldMap snd r
Copy _ r -> foldMap snd r
Var v -> maybe [] snd (envLookup v env)
Patch p -> [fmap (fmap fst) p]
-- | 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) => (Patch (Term syntax ann) -> Maybe (Term syntax ann)) -> (Both ann -> ann) -> Diff syntax ann -> Maybe (Term syntax ann)
mergeMaybe transform extractAnnotation = evalDiff $ \ diff env -> case diff of
Copy _ annotations syntax -> Term . (extractAnnotation annotations :<) <$> sequenceAlt syntax
Copy _ (annotations :< syntax) -> Term . (extractAnnotation annotations :<) <$> sequenceAlt syntax
Var v -> join (envLookup v env)
Patch patch -> traverse sequenceA patch >>= transform . fmap Term
@ -133,7 +133,7 @@ deleting = cata (Diff . Patch . Delete)
copy :: Both ann -> syntax (Diff syntax ann) -> Diff syntax ann
copy = (Diff .) . Copy []
copy = (Diff .) . (Copy [] .) . (:<)
instance Pretty Metavar where
@ -147,7 +147,7 @@ instance (Apply1 Pretty1 fs, Pretty ann) => Pretty (Diff (Union fs) ann) where
pretty = liftPretty pretty prettyList
instance Apply1 Pretty1 fs => Pretty2 (DiffF (Union fs)) where
liftPretty2 pA plA pB plB (Copy bindings (Join ann) f) = pretty ("let" :: String) <+> align (vsep (prettyKV <$> bindings)) <> line <> pretty ("in" :: String) <+> liftPretty2 pA plA pA plA ann <+> liftPrettyUnion pB plB f
liftPretty2 pA plA pB plB (Copy bindings body) = pretty ("let" :: String) <+> align (vsep (prettyKV <$> bindings)) <> line <> pretty ("in" :: String) <+> liftPretty2 (liftPretty pA plA) (list . map (liftPretty pA plA)) pB plB body
where prettyKV (var, val) = pretty var <+> pretty '=' <+> pB val
liftPretty2 _ _ _ _ (Var v) = pretty v
liftPretty2 pA plA pB plB (Patch p) = liftPretty (liftPretty2 pA plA pB plB) (Pretty.list . map (liftPretty2 pA plA pB plB)) p
@ -165,7 +165,7 @@ instance (Eq1 f, Eq a) => Eq (Diff f a) where
instance Eq1 f => Eq2 (DiffF f) where
liftEq2 eqA eqB d1 d2 = case (d1, d2) of
(Copy v1 (Join (a1, b1)) f1, Copy v2 (Join (a2, b2)) f2) -> liftEq (liftEq eqB) v1 v2 && eqA a1 a2 && eqA b1 b2 && liftEq eqB f1 f2
(Copy v1 b1, Copy v2 b2) -> liftEq (liftEq eqB) v1 v2 && liftEq2 (liftEq eqA) eqB b1 b2
(Var v1, Var v2) -> v1 == v2
(Patch p1, Patch p2) -> liftEq (liftEq2 eqA eqB) p1 p2
_ -> False
@ -185,7 +185,7 @@ instance (Show1 f, Show a) => Show (Diff f a) where
instance Show1 f => Show2 (DiffF f) where
liftShowsPrec2 spA slA spB slB d diff = case diff of
Copy bindings ann r -> showParen (d > 10) $ showString "Copy " . liftShowList spB slB bindings . showChar ' ' . liftShowsPrecBoth spA slA 11 ann . showChar ' ' . liftShowsPrec spB slB 11 r
Copy bindings body -> showsBinaryWith (const (liftShowList spB slB)) (liftShowsPrec2 (liftShowsPrec spA slA) (liftShowList spA slA) spB slB) "Copy" d bindings body
Var v -> showsUnaryWith showsPrec "Var" d v
Patch patch -> showsUnaryWith (liftShowsPrec (liftShowsPrec2 spA slA spB slB) (liftShowList2 spA slA spB slB)) "Patch" d patch
@ -207,17 +207,17 @@ instance Traversable f => Traversable (Diff f) where
instance Functor syntax => Bifunctor (DiffF syntax) where
bimap f g (Copy bindings anns r) = Copy (fmap g <$> bindings) (fmap f anns) (fmap g r)
bimap f g (Copy bindings body) = Copy (fmap g <$> bindings) (bimap (fmap f) g body)
bimap _ _ (Var v) = Var v
bimap f g (Patch patch) = Patch (bimap f g <$> patch)
instance Foldable f => Bifoldable (DiffF f) where
bifoldMap f g (Copy vs as r) = foldMap (g . snd) vs `mappend` foldMap f as `mappend` foldMap g r
bifoldMap f g (Copy vs body) = foldMap (g . snd) vs `mappend` bifoldMap (foldMap f) g body
bifoldMap _ _ (Var _) = mempty
bifoldMap f g (Patch p) = foldMap (bifoldMap f g) p
instance Traversable f => Bitraversable (DiffF f) where
bitraverse f g (Copy vs as r) = Copy <$> traverse (traverse g) vs <*> traverse f as <*> traverse g r
bitraverse f g (Copy vs body) = Copy <$> traverse (traverse g) vs <*> bitraverse (traverse f) g body
bitraverse _ _ (Var v) = pure (Var v)
bitraverse f g (Patch p) = Patch <$> traverse (bitraverse f g) p
@ -230,6 +230,6 @@ instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Diff f a) where
toJSONFields = toJSONFields . unDiff
instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (DiffF f a b) where
toJSONFields (Copy vs a f) = [ "bindings" .= vs] <> toJSONFields a <> toJSONFields1 f
toJSONFields (Copy vs body) = [ "bindings" .= vs] <> toJSONFields body
toJSONFields (Var (Metavar v)) = [ "metavar" .= v ]
toJSONFields (Patch a) = toJSONFields a

2
src/Interpreter.hs
View File

@ -125,7 +125,7 @@ editDistanceUpTo :: (GAlign f, Foldable f, Functor f) => Integer -> These (Term
editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDiff a b))
where diffCost = flip . evalDiff $ \ diff env m -> case diff of
_ | m <= 0 -> 0
Copy _ _ r -> sum (fmap ($ pred m) r)
Copy _ body -> sum (fmap ($ pred m) body)
Var v -> maybe 0 ($ pred m) (envLookup v env)
Patch patch -> succ (sum (sum . fmap ($ pred m) <$> patch))
approximateDiff a b = maybe (replacing a b) (copy (both (extract a) (extract b))) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b))

2
src/Renderer/SExpression.hs
View File

@ -32,7 +32,7 @@ printDiffF diff n = case diff of
Delete term -> nl n <> pad (n - 1) <> "{-" <> printTermF term n <> "-}"
Replace a b -> nl n <> pad (n - 1) <> "{ " <> printTermF a n
<> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF b n <> " }"
Copy vs (Join (_, annotation)) syntax -> nl n <> pad n <> "(" <> showBindings (fmap (\ b -> b n) <$> vs) <> showAnnotation annotation <> foldMap (\ d -> d (n + 1)) syntax <> ")"
Copy vs (Join (_, annotation) :< syntax) -> nl n <> pad n <> "(" <> showBindings (fmap (\ b -> b n) <$> vs) <> showAnnotation annotation <> foldMap (\ d -> d (n + 1)) syntax <> ")"
Var v -> nl n <> pad n <> showMetavar v
printTermF :: (ConstrainAll Show fields, Foldable f, Functor f) => TermF f (Record fields) (Int -> ByteString) -> Int -> ByteString

2
src/Renderer/TOC.hs
View File

@ -153,7 +153,7 @@ tableOfContentsBy :: (Foldable f, Functor f)
-> [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
Copy _ ann r -> case (selector (Both.snd ann :< r), fold r) of
Copy _ (ann :< r) -> case (selector (Both.snd ann :< r), fold r) of
(Just a, Nothing) -> Just [Unchanged a]
(Just a, Just []) -> Just [Changed a]
(_ , entries) -> entries