1
1
mirror of https://github.com/github/semantic.git synced 2024-12-27 00:44:57 +03:00

Merge remote-tracking branch 'origin/master' into git-patch-modes

This commit is contained in:
joshvera 2016-02-09 11:03:07 -08:00
commit d3e849c3bf
10 changed files with 113 additions and 18 deletions

View File

@ -59,7 +59,7 @@ printDiff arguments diff sources = case format arguments of
put chunks = do
renderer <- byteStringMakerFromEnvironment
B1.putStr $ mconcat $ chunksToByteStrings renderer chunks
Split -> put (output arguments) =<< split diff sources
Split -> put (output arguments) $ split diff sources
where
put Nothing rendered = TextIO.putStr rendered
put (Just path) rendered = do

View File

@ -10,9 +10,11 @@ import Control.Comonad.Cofree
import qualified Data.Text as T
import Data.Foldable
-- | Return a parser based on the file extension (including the ".").
parserForType :: T.Text -> Parser
parserForType mediaType = maybe lineByLineParser parseTreeSitterFile $ languageForType mediaType
-- | A fallback parser that treats a file simply as rows of strings.
lineByLineParser :: Parser
lineByLineParser input = return . root . Indexed $ case foldl' annotateLeaves ([], 0) lines of
(leaves, _) -> leaves
@ -24,4 +26,3 @@ lineByLineParser input = return . root . Indexed $ case foldl' annotateLeaves ([
(accum ++ [ leaf charIndex (toText line) ]
, charIndex + length line)
toText = T.pack . Source.toString

View File

@ -3,4 +3,5 @@ module Algorithm where
import Control.Monad.Free
import Operation
-- | A lazily-produced AST for diffing.
type Algorithm a annotation = Free (Operation a annotation)

View File

@ -15,6 +15,7 @@ module Data.OrderedMap (
import qualified Data.Maybe as Maybe
-- | An ordered map of keys and values.
data OrderedMap key value = OrderedMap { toList :: [(key, value)] }
deriving (Show, Eq, Functor, Foldable, Traversable)
@ -22,36 +23,46 @@ instance Eq key => Monoid (OrderedMap key value) where
mempty = fromList []
mappend = union
-- | Construct an ordered map from a list of pairs of keys and values.
fromList :: [(key, value)] -> OrderedMap key value
fromList = OrderedMap
-- | Return a list of keys from the map.
keys :: OrderedMap key value -> [key]
keys (OrderedMap pairs) = fst <$> pairs
infixl 9 !
-- | Look up a value in the map by key, erroring if it doesn't exist.
(!) :: Eq key => OrderedMap key value -> key -> value
map ! key = Maybe.fromMaybe (error "no value found for key") $ Data.OrderedMap.lookup key map
-- | Look up a value in the map by key, returning Nothing if it doesn't exist.
lookup :: Eq key => key -> OrderedMap key value -> Maybe value
lookup key = Prelude.lookup key . toList
-- | Return the number of pairs in the map.
size :: OrderedMap key value -> Int
size = length . toList
-- | An empty ordered map.
empty :: OrderedMap key value
empty = OrderedMap []
-- | Combine `a` and `b`, picking the values from `a` when keys overlap.
union :: Eq key => OrderedMap key value -> OrderedMap key value -> OrderedMap key value
union (OrderedMap a) (OrderedMap b) = OrderedMap $ a ++ filter (not . (`elem` extant) . fst) b
where extant = fst <$> a
union a b = OrderedMap $ toList a ++ toList (difference b a)
-- | Union a list of ordered maps.
unions :: Eq key => [OrderedMap key value] -> OrderedMap key value
unions = foldl union empty
-- | Return an ordered map by combining the values from `a` and `b` that have
-- | the same key, dropping any values that are only in one of the maps.
intersectionWith :: Eq key => (a -> b -> c) -> OrderedMap key a -> OrderedMap key b -> OrderedMap key c
intersectionWith combine (OrderedMap a) (OrderedMap b) = OrderedMap $ a >>= (\ (key, value) -> maybe [] (pure . (,) key . combine value) $ Prelude.lookup key b)
-- | Return an ordered map with the pairs from `a` whose key isn't in `b`.
difference :: Eq key => OrderedMap key a -> OrderedMap key b -> OrderedMap key a
difference (OrderedMap a) (OrderedMap b) = OrderedMap $ filter (not . (`elem` extant) . fst) a
difference (OrderedMap a) (OrderedMap b) = OrderedMap $ filter ((`notElem` extant) . fst) a
where extant = fst <$> b

View File

@ -7,44 +7,62 @@ import qualified Data.Vector as Vector
import Text.Blaze.Html5 hiding (map)
import qualified Text.Blaze.Html5.Attributes as A
-- | A line of items or an empty line.
data Line a =
Line (Vector.Vector a)
| EmptyLine
deriving (Eq, Functor, Foldable)
-- | Create a line from a list of items.
makeLine :: [a] -> Line a
makeLine = Line . Vector.fromList
-- | Return a list of items from a line.
unLine :: Line a -> [a]
unLine EmptyLine = []
unLine (Line elements) = Vector.toList elements
-- | Transform the line by applying a function to a list of all the items in the
-- | line.
wrapLineContents :: ([a] -> b) -> Line a -> Line b
wrapLineContents _ EmptyLine = EmptyLine
wrapLineContents transform line = makeLine [ transform (unLine line) ]
-- | Return the first item in the Foldable, or Nothing if it's empty.
maybeFirst :: Foldable f => f a -> Maybe a
maybeFirst = foldr (const . Just) Nothing
-- | Return the last item in the Vector, or Nothing if it's empty.
maybeLast :: Vector.Vector a -> Maybe a
maybeLast vector = if Vector.null vector then Nothing else Just $ Vector.last vector
-- | A function that takes an input and returns a Maybe of the same type.
type MaybeOpen a = a -> Maybe a
-- | Returns the first non-empty line in the list, or Nothing if the last item
-- | in the line doesn't pass the given MaybeOpen or if there are no non-empty
-- | lines.
openLineBy :: MaybeOpen a -> [Line a] -> Maybe (Line a)
openLineBy _ [] = Nothing
openLineBy f (EmptyLine : rest) = openLineBy f rest
openLineBy f (line@(Line vector) : _) = const line <$> (f =<< maybeLast vector)
-- | Given a function that determines whether an item is open, add a line to a
-- | first open, non-empty item in a list of lines, or add it as a new line.
adjoinLinesBy :: MaybeOpen a -> [Line a] -> Line a -> [Line a]
adjoinLinesBy _ [] line = [line]
adjoinLinesBy f (EmptyLine : xs) line | Just _ <- openLineBy f xs = EmptyLine : adjoinLinesBy f xs line
adjoinLinesBy f (prev:rest) line | Just _ <- openLineBy f [ prev ] = (prev <> line) : rest
adjoinLinesBy _ lines line = line : lines
-- | Create a list that contains all of the `a`s in `elements` separated by
-- | `separator`.
intersperse :: Foldable t => a -> t a -> [a]
intersperse separator elements = drop 1 $ foldr (\ each rest -> separator : each : rest) [] elements
-- | Create a list that contains all the items in the foldables in `elements`,
-- | where the contents of the different foldables are separated by the contents
-- | of `separator`.
intercalate :: (Foldable t, Foldable u) => t a -> u (t a) -> [a]
intercalate separator elements = concatMap Foldable.toList $ intersperse separator elements

View File

@ -5,8 +5,16 @@ import Data.OrderedMap
import qualified Data.Text as T
import Term
data Operation a annotation f
= Recursive (Term a annotation) (Term a annotation) (Diff a annotation -> f)
-- | A single step in a diffing algorithm.
data Operation
a -- ^ The type of leaves in the syntax tree, typically String, but possibly some datatype representing different leaves more precisely.
annotation -- ^ The type of annotations.
f -- ^ The type representing another level of the diffing algorithm. Often Algorithm.
=
-- | Recursively diff two terms and pass the result to the continuation.
Recursive (Term a annotation) (Term a annotation) (Diff a annotation -> f)
-- | Diff two dictionaries and pass the result to the continuation.
| ByKey (OrderedMap T.Text (Term a annotation)) (OrderedMap T.Text (Term a annotation)) (OrderedMap T.Text (Diff a annotation) -> f)
-- | Diff two arrays and pass the result to the continuation.
| ByIndex [Term a annotation] [Term a annotation] ([Diff a annotation] -> f)
deriving Functor

View File

@ -17,59 +17,77 @@ import Data.Monoid
import Control.Monad
import Data.Bifunctor
-- | Render a diff in the traditional patch format.
patch :: Renderer a String
patch diff (sourceA, sourceB) = mconcat $ showHunk (sourceA, sourceB) <$> hunks diff (sourceA, sourceB)
-- | A hunk in a patch, including the offset, changes, and context.
data Hunk a = Hunk { offset :: (Sum Int, Sum Int), changes :: [Change a], trailingContext :: [Row a] }
deriving (Eq, Show)
-- | A change in a patch hunk, along with its preceding context.
data Change a = Change { context :: [Row a], contents :: [Row a] }
deriving (Eq, Show)
-- | The number of lines in the hunk before and after.
hunkLength :: Hunk a -> (Sum Int, Sum Int)
hunkLength hunk = mconcat $ (changeLength <$> changes hunk) <> (rowLength <$> trailingContext hunk)
-- | The number of lines in change before and after.
changeLength :: Change a -> (Sum Int, Sum Int)
changeLength change = mconcat $ (rowLength <$> context change) <> (rowLength <$> contents change)
-- | The number of lines in the row, each being either 0 or 1.
rowLength :: Row a -> (Sum Int, Sum Int)
rowLength (Row a b) = (lineLength a, lineLength b)
-- | The length of the line, being either 0 or 1.
lineLength :: Line a -> Sum Int
lineLength EmptyLine = 0
lineLength _ = 1
-- | Given the before and after sources, render a hunk to a string.
showHunk :: (Source Char, Source Char) -> Hunk (SplitDiff a Info) -> String
showHunk sources hunk = header hunk ++ concat (showChange sources <$> changes hunk) ++ showLines (snd sources) ' ' (unRight <$> trailingContext hunk)
-- | Given the before and after sources, render a change to a string.
showChange :: (Source Char, Source Char) -> Change (SplitDiff a Info) -> String
showChange sources change = showLines (snd sources) ' ' (unRight <$> context change) ++ showLines (fst sources) '-' (unLeft <$> contents change) ++ showLines (snd sources) '+' (unRight <$> contents change)
-- | Given a source, render a set of lines to a string with a prefix.
showLines :: Source Char -> Char -> [Line (SplitDiff leaf Info)] -> String
showLines source prefix lines = fromMaybe "" . mconcat $ fmap (prefix :) . showLine source <$> lines
-- | Given a source, render a line to a string.
showLine :: Source Char -> Line (SplitDiff leaf Info) -> Maybe String
showLine _ EmptyLine = Nothing
showLine source line = Just . toString . (`slice` source) . unionRanges $ getRange <$> unLine line
-- | Return the range from a split diff.
getRange :: SplitDiff leaf Info -> Range
getRange (Free (Annotated (Info range _) _)) = range
getRange (Pure (Info range _ :< _)) = range
-- | Return the header for a hunk as a string.
header :: Hunk a -> String
header hunk = "diff --git a/path.txt b/path.txt\n" ++
"@@ -" ++ show offsetA ++ "," ++ show lengthA ++ " +" ++ show offsetB ++ "," ++ show lengthB ++ " @@\n"
where (lengthA, lengthB) = join bimap getSum $ hunkLength hunk
(offsetA, offsetB) = join bimap getSum $ offset hunk
hunks :: Diff a Info -> (Source Char, Source Char) -> [Hunk (SplitDiff a Info)]
-- | Render a diff as a series of hunks.
hunks :: Renderer a [Hunk (SplitDiff a Info)]
hunks diff sources = hunksInRows (1, 1) . fst $ splitDiffByLines diff (0, 0) sources
-- | Given beginning line numbers, turn rows in a split diff into hunks in a
-- | patch.
hunksInRows :: (Sum Int, Sum Int) -> [Row (SplitDiff a Info)] -> [Hunk (SplitDiff a Info)]
hunksInRows start rows = case nextHunk start rows of
Nothing -> []
Just (hunk, rest) -> hunk : hunksInRows (offset hunk <> hunkLength hunk) rest
-- | Given beginning line numbers, return the next hunk and the remaining rows
-- | of the split diff.
nextHunk :: (Sum Int, Sum Int) -> [Row (SplitDiff a Info)] -> Maybe (Hunk (SplitDiff a Info), [Row (SplitDiff a Info)])
nextHunk start rows = case nextChange start rows of
Nothing -> Nothing
@ -80,6 +98,8 @@ nextHunk start rows = case nextChange start rows of
Nothing -> ([], rows)
Just (change, rest) -> let (changes, rest') = contiguousChanges rest in (change : changes, rest')
-- | Given beginning line numbers, return the number of lines to the next
-- | the next change, and the remaining rows of the split diff.
nextChange :: (Sum Int, Sum Int) -> [Row (SplitDiff a Info)] -> Maybe ((Sum Int, Sum Int), Change (SplitDiff a Info), [Row (SplitDiff a Info)])
nextChange start rows = case changeIncludingContext leadingContext afterLeadingContext of
Nothing -> Nothing
@ -87,17 +107,23 @@ nextChange start rows = case changeIncludingContext leadingContext afterLeadingC
where (leadingRows, afterLeadingContext) = break rowHasChanges rows
(skippedContext, leadingContext) = splitAt (max (length leadingRows - 3) 0) leadingRows
-- | Return a Change with the given context and the rows from the begginning of
-- | the given rows that have changes, or Nothing if the first row has no
-- | changes.
changeIncludingContext :: [Row (SplitDiff a Info)] -> [Row (SplitDiff a Info)] -> Maybe (Change (SplitDiff a Info), [Row (SplitDiff a Info)])
changeIncludingContext leadingContext rows = case changes of
[] -> Nothing
_ -> Just (Change leadingContext changes, afterChanges)
where (changes, afterChanges) = span rowHasChanges rows
-- | Whether a row has changes on either side.
rowHasChanges :: Row (SplitDiff a Info) -> Bool
rowHasChanges (Row left right) = lineHasChanges left || lineHasChanges right
-- | Whether a line has changes.
lineHasChanges :: Line (SplitDiff a Info) -> Bool
lineHasChanges = or . fmap diffHasChanges
-- | Whether a split diff has changes.
diffHasChanges :: SplitDiff a Info -> Bool
diffHasChanges = or . fmap (const True)

View File

@ -3,15 +3,20 @@ module Row where
import Control.Arrow
import Line
-- | A row in a split diff, composed of a before line and an after line.
data Row a = Row { unLeft :: !(Line a), unRight :: !(Line a) }
deriving (Eq, Functor)
-- | Return a tuple of lines from the row.
unRow :: Row a -> (Line a, Line a)
unRow (Row a b) = (a, b)
-- | Map over both sides of a row with the given functions.
wrapRowContents :: ([a] -> b) -> ([a] -> b) -> Row a -> Row b
wrapRowContents transformLeft transformRight (Row left right) = Row (wrapLineContents transformLeft left) (wrapLineContents transformRight right)
-- | Given functions that determine whether an item is open, add a row to a
-- | first open, non-empty item in a list of rows, or add it as a new row.
adjoinRowsBy :: MaybeOpen a -> MaybeOpen a -> [Row a] -> Row a -> [Row a]
adjoinRowsBy _ _ [] row = [row]

View File

@ -28,11 +28,14 @@ import Source hiding ((++))
type ClassName = T.Text
-- | Add the first category from a Foldable of categories as a class name as a
-- | class name on the markup, prefixed by `category-`.
classifyMarkup :: Foldable f => f String -> Markup -> Markup
classifyMarkup categories element = maybe element ((element !) . A.class_ . stringValue . ("category-" ++)) $ maybeFirst categories
split :: Renderer leaf (IO TL.Text)
split diff (before, after) = return . renderHtml
-- | Render a diff as an HTML split diff.
split :: Renderer leaf TL.Text
split diff (before, after) = renderHtml
. docTypeHtml
. ((head $ link ! A.rel "stylesheet" ! A.href "style.css") <>)
. body
@ -46,12 +49,14 @@ split diff (before, after) = return . renderHtml
[] -> 0
((x, _, y, _) : _) -> max x y
-- | The number of digits in a number (e.g. 342 has 3 digits).
digits :: Int -> Int
digits n = let base = 10 :: Int in
ceiling (logBase (fromIntegral base) (fromIntegral n) :: Double)
columnWidth = max (20 + digits maxNumber * 8) 40
-- | Render a line with numbers as an HTML row.
numberedLinesToMarkup :: (Int, Line (SplitDiff a Info), Int, Line (SplitDiff a Info)) -> Markup
numberedLinesToMarkup (m, left, n, right) = tr $ toMarkup (or $ hasChanges <$> left, m, renderable before left) <> toMarkup (or $ hasChanges <$> right, n, renderable after right) <> string "\n"
@ -59,19 +64,22 @@ split diff (before, after) = return . renderHtml
hasChanges diff = or $ const True <$> diff
-- | Add a row to list of tuples of ints and lines, where the ints denote
-- | how many non-empty lines exist on that side up to that point.
numberRows :: [(Int, Line a, Int, Line a)] -> Row a -> [(Int, Line a, Int, Line a)]
numberRows [] (Row EmptyLine EmptyLine) = []
numberRows [] (Row left@(Line _) EmptyLine) = [(1, left, 0, EmptyLine)]
numberRows [] (Row EmptyLine right@(Line _)) = [(0, EmptyLine, 1, right)]
numberRows [] (Row left right) = [(1, left, 1, right)]
numberRows rows@((leftCount, _, rightCount, _):_) (Row EmptyLine EmptyLine) = (leftCount, EmptyLine, rightCount, EmptyLine):rows
numberRows rows@((leftCount, _, rightCount, _):_) (Row left@(Line _) EmptyLine) = (leftCount + 1, left, rightCount, EmptyLine):rows
numberRows rows@((leftCount, _, rightCount, _):_) (Row EmptyLine right@(Line _)) = (leftCount, EmptyLine, rightCount + 1, right):rows
numberRows rows@((leftCount, _, rightCount, _):_) (Row left right) = (leftCount + 1, left, rightCount + 1, right):rows
numberRows rows (Row left right) = (leftCount rows + valueOf left, left, rightCount rows + valueOf right, right) : rows
where
leftCount [] = 0
leftCount ((x, _, _, _):_) = x
rightCount [] = 0
rightCount ((_, _, x, _):_) = x
valueOf EmptyLine = 0
valueOf _ = 1
-- | A diff with only one sides annotations.
type SplitDiff leaf annotation = Free (Annotated leaf annotation) (Term leaf annotation)
-- | Something that can be rendered as markup.
newtype Renderable a = Renderable (Source Char, a)
instance ToMarkup f => ToMarkup (Renderable (Info, Syntax a (f, Range))) where
@ -94,6 +102,7 @@ instance ToMarkup (Renderable (SplitDiff a Info)) where
where toMarkupAndRange :: Term a Info -> (Markup, Range)
toMarkupAndRange term@(Info range _ :< _) = ((div ! A.class_ (stringValue "patch")) . toMarkup $ Renderable (source, term), range)
-- | Split a diff, which may span multiple lines, into rows of split diffs.
splitDiffByLines :: Diff leaf Info -> (Int, Int) -> (Source Char, Source Char) -> ([Row (SplitDiff leaf Info)], (Range, Range))
splitDiffByLines diff (prevLeft, prevRight) sources = case diff of
Free (Annotated annotation syntax) -> (splitAnnotatedByLines sources (ranges annotation) (categories annotation) syntax, ranges annotation)
@ -107,6 +116,7 @@ splitDiffByLines diff (prevLeft, prevRight) sources = case diff of
where categories (Info _ left, Info _ right) = (left, right)
ranges (Info left _, Info right _) = (left, right)
-- | A functor that can return its content.
class Functor f => Has f where
get :: f a -> a
@ -141,6 +151,7 @@ splitTermByLines (Info range categories :< syntax) source = flip (,) range $ cas
childLines (lines, previous) child = let (childLines, childRange) = splitTermByLines (get child) source in
(adjoin $ lines ++ (pure . Left <$> actualLineRanges (Range previous $ start childRange) source) ++ (fmap (Right . (<$ child)) <$> childLines), end childRange)
-- | Split a annotated diff into rows of split diffs.
splitAnnotatedByLines :: (Source Char, Source Char) -> (Range, Range) -> (Set.Set Category, Set.Set Category) -> Syntax leaf (Diff leaf Info) -> [Row (SplitDiff leaf Info)]
splitAnnotatedByLines sources ranges categories syntax = case syntax of
Leaf a -> wrapRowContents (Free . (`Annotated` Leaf a) . (`Info` fst categories) . unionRanges) (Free . (`Annotated` Leaf a) . (`Info` snd categories) . unionRanges) <$> contextRows ranges sources
@ -176,21 +187,31 @@ splitAnnotatedByLines sources ranges categories syntax = case syntax of
ends (left, right) = (end left, end right)
makeRanges (leftStart, rightStart) (leftEnd, rightEnd) = (Range leftStart leftEnd, Range rightStart rightEnd)
-- | Returns a function that takes an Either, applies either the left or right
-- | MaybeOpen, and returns Nothing or the original either.
openEither :: MaybeOpen a -> MaybeOpen b -> MaybeOpen (Either a b)
openEither ifLeft ifRight which = either (fmap (const which) . ifLeft) (fmap (const which) . ifRight) which
-- | Given a source and a range, returns nothing if it ends with a `\n`;
-- | otherwise returns the range.
openRange :: Source Char -> MaybeOpen Range
openRange source range = case (source `at`) <$> maybeLastIndex range of
Just '\n' -> Nothing
_ -> Just range
-- | Given a source and something that has a term, returns nothing if the term
-- | ends with a `\n`; otherwise returns the term.
openTerm :: Has f => Source Char -> MaybeOpen (f (Term leaf Info))
openTerm source term = const term <$> openRange source (case get term of (Info range _ :< _) -> range)
-- | Given a source and something that has a split diff, returns nothing if the
-- | diff ends with a `\n`; otherwise returns the diff.
openDiff :: Has f => Source Char -> MaybeOpen (f (SplitDiff leaf Info))
openDiff source diff = const diff <$> case get diff of
(Free (Annotated (Info range _) _)) -> openRange source range
(Pure (Info range _ :< _)) -> openRange source range
-- | Zip two lists by applying a function, using the default values to extend
-- | the shorter list.
zipWithDefaults :: (a -> b -> c) -> a -> b -> [a] -> [b] -> [c]
zipWithDefaults f da db a b = take (max (length a) (length b)) $ zipWith f (a ++ repeat da) (b ++ repeat db)

View File

@ -40,8 +40,10 @@ foreign import ccall "app/bridge.h ts_node_p_named_child" ts_node_p_named_child
foreign import ccall "app/bridge.h ts_node_p_start_char" ts_node_p_start_char :: Ptr TSNode -> CSize
foreign import ccall "app/bridge.h ts_node_p_end_char" ts_node_p_end_char :: Ptr TSNode -> CSize
-- | A language in the eyes of semantic-diff.
data Language = Language { getTsLanguage :: Ptr TSLanguage, getConstructor :: Constructor }
-- | Returns a Language based on the file extension (including the ".").
languageForType :: T.Text -> Maybe Language
languageForType mediaType = case mediaType of
".h" -> c
@ -52,6 +54,7 @@ languageForType mediaType = case mediaType of
_ -> Nothing
where c = Just . Language ts_language_c $ constructorForProductions mempty (Set.fromList [ "assignment_expression", "logical_expression", "pointer_expression", "field_expression", "relational_expression", "designator", "call_expression", "math_expression" ])
-- | Returns a parser for the given language.
parseTreeSitterFile :: Language -> Parser
parseTreeSitterFile (Language language constructor) contents = do
document <- ts_document_make
@ -63,6 +66,7 @@ parseTreeSitterFile (Language language constructor) contents = do
ts_document_free document
return term)
-- | Given a constructor and a tree sitter document, return a parser.
documentToTerm :: Constructor -> Ptr TSDocument -> Parser
documentToTerm constructor document contents = alloca $ \ root -> do
ts_document_root_node_p document root