mirror of
https://github.com/github/semantic.git
synced 2024-12-26 16:33:03 +03:00
Merge pull request #414 from github/belly-of-the-beast
Document Split.hs and related files
This commit is contained in:
commit
965ede0623
@ -59,7 +59,7 @@ printDiff arguments diff sources = case format arguments of
|
|||||||
put chunks = do
|
put chunks = do
|
||||||
renderer <- byteStringMakerFromEnvironment
|
renderer <- byteStringMakerFromEnvironment
|
||||||
B1.putStr $ mconcat $ chunksToByteStrings renderer chunks
|
B1.putStr $ mconcat $ chunksToByteStrings renderer chunks
|
||||||
Split -> put (output arguments) =<< split diff sources
|
Split -> put (output arguments) $ split diff sources
|
||||||
where
|
where
|
||||||
put Nothing rendered = TextIO.putStr rendered
|
put Nothing rendered = TextIO.putStr rendered
|
||||||
put (Just path) rendered = do
|
put (Just path) rendered = do
|
||||||
|
18
src/Line.hs
18
src/Line.hs
@ -7,44 +7,62 @@ import qualified Data.Vector as Vector
|
|||||||
import Text.Blaze.Html5 hiding (map)
|
import Text.Blaze.Html5 hiding (map)
|
||||||
import qualified Text.Blaze.Html5.Attributes as A
|
import qualified Text.Blaze.Html5.Attributes as A
|
||||||
|
|
||||||
|
-- | A line of items or an empty line.
|
||||||
data Line a =
|
data Line a =
|
||||||
Line (Vector.Vector a)
|
Line (Vector.Vector a)
|
||||||
| EmptyLine
|
| EmptyLine
|
||||||
deriving (Eq, Functor, Foldable)
|
deriving (Eq, Functor, Foldable)
|
||||||
|
|
||||||
|
-- | Create a line from a list of items.
|
||||||
makeLine :: [a] -> Line a
|
makeLine :: [a] -> Line a
|
||||||
makeLine = Line . Vector.fromList
|
makeLine = Line . Vector.fromList
|
||||||
|
|
||||||
|
-- | Return a list of items from a line.
|
||||||
unLine :: Line a -> [a]
|
unLine :: Line a -> [a]
|
||||||
unLine EmptyLine = []
|
unLine EmptyLine = []
|
||||||
unLine (Line elements) = Vector.toList elements
|
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 :: ([a] -> b) -> Line a -> Line b
|
||||||
wrapLineContents _ EmptyLine = EmptyLine
|
wrapLineContents _ EmptyLine = EmptyLine
|
||||||
wrapLineContents transform line = makeLine [ transform (unLine line) ]
|
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 :: Foldable f => f a -> Maybe a
|
||||||
maybeFirst = foldr (const . Just) Nothing
|
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.Vector a -> Maybe a
|
||||||
maybeLast vector = if Vector.null vector then Nothing else Just $ Vector.last vector
|
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
|
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 :: MaybeOpen a -> [Line a] -> Maybe (Line a)
|
||||||
openLineBy _ [] = Nothing
|
openLineBy _ [] = Nothing
|
||||||
openLineBy f (EmptyLine : rest) = openLineBy f rest
|
openLineBy f (EmptyLine : rest) = openLineBy f rest
|
||||||
openLineBy f (line@(Line vector) : _) = const line <$> (f =<< maybeLast vector)
|
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 :: MaybeOpen a -> [Line a] -> Line a -> [Line a]
|
||||||
adjoinLinesBy _ [] line = [line]
|
adjoinLinesBy _ [] line = [line]
|
||||||
adjoinLinesBy f (EmptyLine : xs) line | Just _ <- openLineBy f xs = EmptyLine : adjoinLinesBy f xs 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 f (prev:rest) line | Just _ <- openLineBy f [ prev ] = (prev <> line) : rest
|
||||||
adjoinLinesBy _ lines line = line : lines
|
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 :: Foldable t => a -> t a -> [a]
|
||||||
intersperse separator elements = drop 1 $ foldr (\ each rest -> separator : each : rest) [] elements
|
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 :: (Foldable t, Foldable u) => t a -> u (t a) -> [a]
|
||||||
intercalate separator elements = concatMap Foldable.toList $ intersperse separator elements
|
intercalate separator elements = concatMap Foldable.toList $ intersperse separator elements
|
||||||
|
|
||||||
|
@ -3,15 +3,20 @@ module Row where
|
|||||||
import Control.Arrow
|
import Control.Arrow
|
||||||
import Line
|
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) }
|
data Row a = Row { unLeft :: !(Line a), unRight :: !(Line a) }
|
||||||
deriving (Eq, Functor)
|
deriving (Eq, Functor)
|
||||||
|
|
||||||
|
-- | Return a tuple of lines from the row.
|
||||||
unRow :: Row a -> (Line a, Line a)
|
unRow :: Row a -> (Line a, Line a)
|
||||||
unRow (Row a b) = (a, b)
|
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 :: ([a] -> b) -> ([a] -> b) -> Row a -> Row b
|
||||||
wrapRowContents transformLeft transformRight (Row left right) = Row (wrapLineContents transformLeft left) (wrapLineContents transformRight right)
|
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 :: MaybeOpen a -> MaybeOpen a -> [Row a] -> Row a -> [Row a]
|
||||||
adjoinRowsBy _ _ [] row = [row]
|
adjoinRowsBy _ _ [] row = [row]
|
||||||
|
|
||||||
|
41
src/Split.hs
41
src/Split.hs
@ -28,11 +28,14 @@ import Source hiding ((++))
|
|||||||
|
|
||||||
type ClassName = T.Text
|
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 :: Foldable f => f String -> Markup -> Markup
|
||||||
classifyMarkup categories element = maybe element ((element !) . A.class_ . stringValue . ("category-" ++)) $ maybeFirst categories
|
classifyMarkup categories element = maybe element ((element !) . A.class_ . stringValue . ("category-" ++)) $ maybeFirst categories
|
||||||
|
|
||||||
split :: Renderer leaf (IO TL.Text)
|
-- | Render a diff as an HTML split diff.
|
||||||
split diff (before, after) = return . renderHtml
|
split :: Renderer leaf TL.Text
|
||||||
|
split diff (before, after) = renderHtml
|
||||||
. docTypeHtml
|
. docTypeHtml
|
||||||
. ((head $ link ! A.rel "stylesheet" ! A.href "style.css") <>)
|
. ((head $ link ! A.rel "stylesheet" ! A.href "style.css") <>)
|
||||||
. body
|
. body
|
||||||
@ -46,12 +49,14 @@ split diff (before, after) = return . renderHtml
|
|||||||
[] -> 0
|
[] -> 0
|
||||||
((x, _, y, _) : _) -> max x y
|
((x, _, y, _) : _) -> max x y
|
||||||
|
|
||||||
|
-- | The number of digits in a number (e.g. 342 has 3 digits).
|
||||||
digits :: Int -> Int
|
digits :: Int -> Int
|
||||||
digits n = let base = 10 :: Int in
|
digits n = let base = 10 :: Int in
|
||||||
ceiling (logBase (fromIntegral base) (fromIntegral n) :: Double)
|
ceiling (logBase (fromIntegral base) (fromIntegral n) :: Double)
|
||||||
|
|
||||||
columnWidth = max (20 + digits maxNumber * 8) 40
|
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 :: (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"
|
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
|
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 :: [(Int, Line a, Int, Line a)] -> Row a -> [(Int, Line a, Int, Line a)]
|
||||||
numberRows [] (Row EmptyLine EmptyLine) = []
|
numberRows rows (Row left right) = (leftCount rows + valueOf left, left, rightCount rows + valueOf right, right) : rows
|
||||||
numberRows [] (Row left@(Line _) EmptyLine) = [(1, left, 0, EmptyLine)]
|
where
|
||||||
numberRows [] (Row EmptyLine right@(Line _)) = [(0, EmptyLine, 1, right)]
|
leftCount [] = 0
|
||||||
numberRows [] (Row left right) = [(1, left, 1, right)]
|
leftCount ((x, _, _, _):_) = x
|
||||||
numberRows rows@((leftCount, _, rightCount, _):_) (Row EmptyLine EmptyLine) = (leftCount, EmptyLine, rightCount, EmptyLine):rows
|
rightCount [] = 0
|
||||||
numberRows rows@((leftCount, _, rightCount, _):_) (Row left@(Line _) EmptyLine) = (leftCount + 1, left, rightCount, EmptyLine):rows
|
rightCount ((_, _, x, _):_) = x
|
||||||
numberRows rows@((leftCount, _, rightCount, _):_) (Row EmptyLine right@(Line _)) = (leftCount, EmptyLine, rightCount + 1, right):rows
|
valueOf EmptyLine = 0
|
||||||
numberRows rows@((leftCount, _, rightCount, _):_) (Row left right) = (leftCount + 1, left, rightCount + 1, right):rows
|
valueOf _ = 1
|
||||||
|
|
||||||
-- | A diff with only one side’s annotations.
|
-- | A diff with only one side’s annotations.
|
||||||
type SplitDiff leaf annotation = Free (Annotated leaf annotation) (Term leaf annotation)
|
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)
|
newtype Renderable a = Renderable (Source Char, a)
|
||||||
|
|
||||||
instance ToMarkup f => ToMarkup (Renderable (Info, Syntax a (f, Range))) where
|
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)
|
where toMarkupAndRange :: Term a Info -> (Markup, Range)
|
||||||
toMarkupAndRange term@(Info range _ :< _) = ((div ! A.class_ (stringValue "patch")) . toMarkup $ Renderable (source, term), 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 leaf Info -> (Int, Int) -> (Source Char, Source Char) -> ([Row (SplitDiff leaf Info)], (Range, Range))
|
||||||
splitDiffByLines diff (prevLeft, prevRight) sources = case diff of
|
splitDiffByLines diff (prevLeft, prevRight) sources = case diff of
|
||||||
Free (Annotated annotation syntax) -> (splitAnnotatedByLines sources (ranges annotation) (categories annotation) syntax, ranges annotation)
|
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)
|
where categories (Info _ left, Info _ right) = (left, right)
|
||||||
ranges (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
|
class Functor f => Has f where
|
||||||
get :: f a -> a
|
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
|
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)
|
(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 :: (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
|
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
|
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)
|
ends (left, right) = (end left, end right)
|
||||||
makeRanges (leftStart, rightStart) (leftEnd, rightEnd) = (Range leftStart leftEnd, Range rightStart rightEnd)
|
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 :: MaybeOpen a -> MaybeOpen b -> MaybeOpen (Either a b)
|
||||||
openEither ifLeft ifRight which = either (fmap (const which) . ifLeft) (fmap (const which) . ifRight) which
|
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 Char -> MaybeOpen Range
|
||||||
openRange source range = case (source `at`) <$> maybeLastIndex range of
|
openRange source range = case (source `at`) <$> maybeLastIndex range of
|
||||||
Just '\n' -> Nothing
|
Just '\n' -> Nothing
|
||||||
_ -> Just range
|
_ -> 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 :: Has f => Source Char -> MaybeOpen (f (Term leaf Info))
|
||||||
openTerm source term = const term <$> openRange source (case get term of (Info range _ :< _) -> range)
|
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 :: Has f => Source Char -> MaybeOpen (f (SplitDiff leaf Info))
|
||||||
openDiff source diff = const diff <$> case get diff of
|
openDiff source diff = const diff <$> case get diff of
|
||||||
(Free (Annotated (Info range _) _)) -> openRange source range
|
(Free (Annotated (Info range _) _)) -> openRange source range
|
||||||
(Pure (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 :: (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)
|
zipWithDefaults f da db a b = take (max (length a) (length b)) $ zipWith f (a ++ repeat da) (b ++ repeat db)
|
||||||
|
Loading…
Reference in New Issue
Block a user