github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-29 09:55:52 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into forward-compatible-rendering

Browse Source 
# Conflicts:
#	src/DiffOutput.hs
#	src/Renderer/Split.hs
#	test/CorpusSpec.hs
This commit is contained in:
Rob Rix 2016-03-01 12:34:40 -05:00
commit e894d63a6c
19 changed files with 273 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
semantic-diff.cabal
View File

@ -18,7 +18,7 @@ library
, Category
, Control.Comonad.Cofree
, Control.Monad.Free
, Data.Bifunctor.Join
, Data.Functor.Both
, Data.Option
, Data.OrderedMap
, Diff

54
src/Alignment.hs
View File

@ -4,12 +4,15 @@ import Category
import Control.Comonad.Cofree
import Control.Monad.Free
import Data.Either
import Data.Functor.Both
import Data.Functor.Identity
import qualified Data.OrderedMap as Map
import qualified Data.Set as Set
import Diff
import Line
import Patch
import Prelude hiding (fst, snd)
import qualified Prelude
import Range
import Row
import Source hiding ((++))
@ -18,18 +21,18 @@ import Syntax
import Term
-- | 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
splitDiffByLines :: Diff leaf Info -> Both Int -> Both (Source Char) -> ([Row (SplitDiff leaf Info)], Both Range)
splitDiffByLines diff previous sources = case diff of
Free (Annotated annotation syntax) -> (splitAnnotatedByLines sources (ranges annotation) (categories annotation) syntax, ranges annotation)
Pure (Insert term) -> let (lines, range) = splitTermByLines term (snd sources) in
(Row EmptyLine . fmap (Pure . SplitInsert) <$> lines, (Range prevLeft prevLeft, range))
(makeRow EmptyLine . fmap (Pure . SplitInsert) <$> lines, Both (rangeAt $ fst previous, range))
Pure (Delete term) -> let (lines, range) = splitTermByLines term (fst sources) in
(flip Row EmptyLine . fmap (Pure . SplitDelete) <$> lines, (range, Range prevRight prevRight))
Pure (Replace leftTerm rightTerm) -> let (leftLines, leftRange) = splitTermByLines leftTerm (fst sources)
(rightLines, rightRange) = splitTermByLines rightTerm (snd sources) in
(zipWithDefaults Row EmptyLine EmptyLine (fmap (Pure . SplitReplace) <$> leftLines) (fmap (Pure . SplitReplace) <$> rightLines), (leftRange, rightRange))
where categories (Info _ left, Info _ right) = (left, right)
ranges (Info left _, Info right _) = (left, right)
(flip makeRow EmptyLine . fmap (Pure . SplitDelete) <$> lines, Both (range, rangeAt $ snd previous))
Pure (Replace leftTerm rightTerm) -> let Both ((leftLines, leftRange), (rightLines, rightRange)) = splitTermByLines <$> Both (leftTerm, rightTerm) <*> sources
(lines, ranges) = (Both (leftLines, rightLines), Both (leftRange, rightRange)) in
(zipWithDefaults makeRow (pure mempty) $ fmap (fmap (Pure . SplitReplace)) <$> lines, ranges)
where categories annotations = Diff.categories <$> annotations
ranges annotations = characterRange <$> annotations
-- | A functor that can return its content.
class Functor f => Has f where
@ -39,7 +42,7 @@ instance Has Identity where
get = runIdentity
instance Has ((,) a) where
get = snd
get = Prelude.snd
-- | Takes a term and a source and returns a list of lines and their range within source.
splitTermByLines :: Term leaf Info -> Source Char -> ([Line (Term leaf Info)], Range)
@ -67,23 +70,21 @@ splitTermByLines (Info range categories :< syntax) source = flip (,) range $ cas
(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 :: Both (Source Char) -> Both Range -> Both (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
Leaf a -> wrapRowContents (((Free . (`Annotated` Leaf a)) .) <$> ((. unionRanges) . flip Info <$> categories)) <$> contextRows ranges sources
Indexed children -> adjoinChildRows (Indexed . fmap get) (Identity <$> children)
Fixed children -> adjoinChildRows (Fixed . fmap get) (Identity <$> children)
Keyed children -> adjoinChildRows (Keyed . Map.fromList) (Map.toList children)
where contextRows :: (Range, Range) -> (Source Char, Source Char) -> [Row Range]
contextRows ranges sources = zipWithDefaults Row EmptyLine EmptyLine
(pure <$> actualLineRanges (fst ranges) (fst sources))
(pure <$> actualLineRanges (snd ranges) (snd sources))
where contextRows :: Both Range -> Both (Source Char) -> [Row Range]
contextRows ranges sources = zipWithDefaults makeRow (pure mempty) (fmap pure <$> (actualLineRanges <$> ranges <*> sources))
adjoin :: Has f => [Row (Either Range (f (SplitDiff leaf Info)))] -> [Row (Either Range (f (SplitDiff leaf Info)))]
adjoin = reverse . foldl (adjoinRowsBy (openEither (openRange $ fst sources) (openDiff $ fst sources)) (openEither (openRange $ snd sources) (openDiff $ snd sources))) []
adjoin = reverse . foldl (adjoinRowsBy (openEither <$> (openRange <$> sources) <*> (openDiff <$> sources))) []
adjoinChildRows :: (Has f) => ([f (SplitDiff leaf Info)] -> Syntax leaf (SplitDiff leaf Info)) -> [f (Diff leaf Info)] -> [Row (SplitDiff leaf Info)]
adjoinChildRows constructor children = let (rows, previous) = foldl childRows ([], starts ranges) children in
fmap (wrapRowContents (wrap constructor (fst categories)) (wrap constructor (snd categories))) . adjoin $ rows ++ (fmap Left <$> contextRows (makeRanges previous (ends ranges)) sources)
adjoinChildRows :: Has f => ([f (SplitDiff leaf Info)] -> Syntax leaf (SplitDiff leaf Info)) -> [f (Diff leaf Info)] -> [Row (SplitDiff leaf Info)]
adjoinChildRows constructor children = let (rows, previous) = foldl childRows ([], start <$> ranges) children in
fmap (wrapRowContents (wrap constructor <$> categories)) . adjoin $ rows ++ (fmap Left <$> contextRows (makeRanges previous (end <$> ranges)) sources)
wrap :: Has f => ([f (SplitDiff leaf Info)] -> Syntax leaf (SplitDiff leaf Info)) -> Set.Set Category -> [Either Range (f (SplitDiff leaf Info))] -> SplitDiff leaf Info
wrap constructor categories children = Free . Annotated (Info (unionRanges $ getRange <$> children) categories) . constructor $ rights children
@ -94,13 +95,11 @@ splitAnnotatedByLines sources ranges categories syntax = case syntax of
(Free (Annotated (Info range _) _)) -> range
getRange (Left range) = range
childRows :: (Has f) => ([Row (Either Range (f (SplitDiff leaf Info)))], (Int, Int)) -> f (Diff leaf Info) -> ([Row (Either Range (f (SplitDiff leaf Info)))], (Int, Int))
childRows :: Has f => ([Row (Either Range (f (SplitDiff leaf Info)))], Both Int) -> f (Diff leaf Info) -> ([Row (Either Range (f (SplitDiff leaf Info)))], Both Int)
childRows (rows, previous) child = let (childRows, childRanges) = splitDiffByLines (get child) previous sources in
(adjoin $ rows ++ (fmap Left <$> contextRows (makeRanges previous (starts childRanges)) sources) ++ (fmap (Right . (<$ child)) <$> childRows), ends childRanges)
(adjoin $ rows ++ (fmap Left <$> contextRows (makeRanges previous (start <$> childRanges)) sources) ++ (fmap (Right . (<$ child)) <$> childRows), end <$> childRanges)
starts (left, right) = (start left, start right)
ends (left, right) = (end left, end right)
makeRanges (leftStart, rightStart) (leftEnd, rightEnd) = (Range leftStart leftEnd, Range rightStart rightEnd)
makeRanges (Both (leftStart, rightStart)) (Both (leftEnd, rightEnd)) = Both (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.
@ -125,8 +124,3 @@ 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 patch) -> let Info range _ :< _ = getSplitTerm patch in 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)

8
src/Data/Bifunctor/Join.hs
View File

@ -1,8 +0,0 @@
module Data.Bifunctor.Join where
newtype Join a = Join { runJoin :: (a, a) }
deriving (Eq, Show, Functor, Foldable, Traversable)
instance Applicative Join where
pure a = Join (a, a)
Join (f, g) <*> Join (a, b) = Join (f a, g b)

49
src/Data/Functor/Both.hs Normal file
View File

@ -0,0 +1,49 @@
module Data.Functor.Both where
import Prelude hiding (zipWith, fst, snd)
import qualified Prelude
-- | A computation over both sides of a pair.
newtype Both a = Both { runBoth :: (a, a) }
deriving (Eq, Show, Functor, Foldable, Traversable)
-- | Given two operands returns a functor operating on `Both`. This is a curried synonym for Both.
both :: a -> a -> Both a
both = curry Both
-- | Apply a function to `Both` sides of a computation.
runBothWith :: (a -> a -> b) -> Both a -> b
runBothWith f = uncurry f . runBoth
-- | Runs the left side of a `Both`.
fst :: Both a -> a
fst = Prelude.fst . runBoth
-- | Runs the right side of a `Both`.
snd :: Both a -> a
snd = Prelude.snd . runBoth
zip :: Both [a] -> [Both a]
zip = zipWith both
-- | Zip two lists by applying a function, using the default values to extend
-- | the shorter list.
zipWithDefaults :: (a -> a -> b) -> Both a -> Both [a] -> [b]
zipWithDefaults f ds as = take (runBothWith max (length <$> as)) $ zipWith f ((++) <$> as <*> (repeat <$> ds))
zipWith :: (a -> a -> b) -> Both [a] -> [b]
zipWith _ (Both ([], _)) = []
zipWith _ (Both (_, [])) = []
zipWith f (Both (a : as, b : bs)) = f a b : zipWith f (both as bs)
unzip :: [Both a] -> Both [a]
unzip = foldr pair (pure [])
where pair (Both (a, b)) (Both (as, bs)) = Both (a : as, b : bs)
instance Applicative Both where
pure a = Both (a, a)
Both (f, g) <*> Both (a, b) = Both (f a, g b)
instance Monoid a => Monoid (Both a) where
mempty = pure mempty
mappend a b = mappend <$> a <*> b

15
src/Diff.hs
View File

@ -1,12 +1,13 @@
module Diff where
import Syntax
import Data.Set
import Control.Monad.Free
import Patch
import Term
import Range
import Category
import Control.Monad.Free
import Data.Functor.Both
import Data.Set
import Patch
import Range
import Syntax
import Term
-- | An annotated syntax in a diff tree.
data Annotated a annotation f = Annotated { getAnnotation :: !annotation, getSyntax :: !(Syntax a f) }
@ -21,7 +22,7 @@ instance Categorizable Info where
categories = Diff.categories
-- | An annotated series of patches of terms.
type Diff a annotation = Free (Annotated a (annotation, annotation)) (Patch (Term a annotation))
type Diff a annotation = Free (Annotated a (Both annotation)) (Patch (Term a annotation))
-- | Sum the result of a transform applied to all the patches in the diff.
diffSum :: (Patch (Term a annotation) -> Integer) -> Diff a annotation -> Integer

5
src/DiffOutput.hs
View File

@ -1,7 +1,8 @@
module DiffOutput where
import qualified Data.Text.Lazy.IO as TextIO
import qualified Data.ByteString.Lazy as B
import qualified Data.Text.Lazy.IO as TextIO
import Data.Functor.Both
import Diffing
import Parser
import qualified Renderer.JSON as J
@ -18,7 +19,7 @@ data Format = Split | Patch | JSON
data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath, outputPath :: FilePath }
-- | Return a renderer from the command-line arguments that will print the diff.
printDiff :: Parser -> DiffArguments -> (SourceBlob, SourceBlob) -> IO ()
printDiff :: Parser -> DiffArguments -> Both SourceBlob -> IO ()
printDiff parser arguments sources = case format arguments of
Split -> put (output arguments) =<< diffFiles parser split sources
where

9
src/Diffing.hs
View File

@ -13,8 +13,7 @@ import TreeSitter
import Text.Parser.TreeSitter.Language
import Control.Comonad.Cofree
import Control.Arrow
import Data.Bifunctor.Join
import Data.Functor.Both
import qualified Data.ByteString.Char8 as B1
import Data.Foldable
import qualified Data.Text as T
@ -71,9 +70,9 @@ readAndTranscodeFile path = do
-- | Given a parser and renderer, diff two sources and return the rendered
-- | result.
diffFiles :: Parser -> Renderer T.Text b -> (SourceBlob, SourceBlob) -> IO b
diffFiles :: Parser -> Renderer T.Text b -> Both SourceBlob -> IO b
diffFiles parser renderer sourceBlobs = do
let sources = Join $ (source *** source) sourceBlobs
let sources = source <$> sourceBlobs
terms <- sequence $ parser <$> sources
let replaceLeaves = breakDownLeavesByWord <$> sources
return $ renderer (uncurry diffTerms $ runJoin $ replaceLeaves <*> terms) sourceBlobs
return $ renderer (runBothWith diffTerms $ replaceLeaves <*> terms) sourceBlobs

11
src/Interpreter.hs
View File

@ -11,6 +11,7 @@ import Term
import Category
import Control.Monad.Free
import Control.Comonad.Cofree hiding (unwrap)
import Data.Functor.Both
import qualified Data.OrderedMap as Map
import Data.OrderedMap ((!))
import qualified Data.List as List
@ -39,7 +40,7 @@ constructAndRun :: (Eq a, Eq annotation) => Comparable a annotation -> Term a an
constructAndRun _ a b | a == b = hylo introduce eliminate <$> zipTerms a b where
eliminate :: Cofree f a -> (a, f (Cofree f a))
eliminate (extract :< unwrap) = (extract, unwrap)
introduce :: (annotation, annotation) -> Syntax a (Diff a annotation) -> Diff a annotation
introduce :: Both annotation -> Syntax a (Diff a annotation) -> Diff a annotation
introduce ann syntax = Free $ Annotated ann syntax
constructAndRun comparable a b | not $ comparable a b = Nothing
constructAndRun comparable (annotation1 :< a) (annotation2 :< b) =
@ -48,15 +49,15 @@ constructAndRun comparable (annotation1 :< a) (annotation2 :< b) =
algorithm (Keyed a') (Keyed b') = Free $ ByKey a' b' (annotate . Keyed)
algorithm (Leaf a') (Leaf b') | a' == b' = annotate $ Leaf b'
algorithm a' b' = Free $ Recursive (annotation1 :< a') (annotation2 :< b') Pure
annotate = Pure . Free . Annotated (annotation1, annotation2)
annotate = Pure . Free . Annotated (Both (annotation1, annotation2))
-- | Runs the diff algorithm
run :: (Eq a, Eq annotation) => Comparable a annotation -> Algorithm a annotation (Diff a annotation) -> Maybe (Diff a annotation)
run _ (Pure diff) = Just diff
run comparable (Free (Recursive (annotation1 :< a) (annotation2 :< b) f)) = run comparable . f $ recur a b where
recur (Indexed a') (Indexed b') | length a' == length b' = annotate . Indexed $ zipWith (interpret comparable) a' b'
recur (Fixed a') (Fixed b') | length a' == length b' = annotate . Fixed $ zipWith (interpret comparable) a' b'
recur (Indexed a') (Indexed b') | length a' == length b' = annotate . Indexed $ Prelude.zipWith (interpret comparable) a' b'
recur (Fixed a') (Fixed b') | length a' == length b' = annotate . Fixed $ Prelude.zipWith (interpret comparable) a' b'
recur (Keyed a') (Keyed b') | Map.keys a' == bKeys = annotate . Keyed . Map.fromList . fmap repack $ bKeys
where
bKeys = Map.keys b'
@ -64,7 +65,7 @@ run comparable (Free (Recursive (annotation1 :< a) (annotation2 :< b) f)) = run
interpretInBoth key x y = interpret comparable (x ! key) (y ! key)
recur _ _ = Pure $ Replace (annotation1 :< a) (annotation2 :< b)
annotate = Free . Annotated (annotation1, annotation2)
annotate = Free . Annotated (Both (annotation1, annotation2))
run comparable (Free (ByKey a b f)) = run comparable $ f byKey where
byKey = Map.fromList $ toKeyValue <$> List.union aKeys bKeys

8
src/Line.hs
View File

@ -4,8 +4,6 @@ module Line where
import qualified Data.Foldable as Foldable
import Data.Monoid
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 =
@ -79,9 +77,3 @@ instance Monoid (Line a) where
mappend EmptyLine line = line
mappend line EmptyLine = line
mappend (Line xs) (Line ys) = Line (xs <> ys)
instance ToMarkup a => ToMarkup (Bool, Int, Line a) where
toMarkup (_, _, EmptyLine) = td mempty ! A.class_ (stringValue "blob-num blob-num-empty empty-cell") <> td mempty ! A.class_ (stringValue "blob-code blob-code-empty empty-cell") <> string "\n"
toMarkup (hasChanges, num, Line contents)
= td (string $ show num) ! A.class_ (stringValue $ if hasChanges then "blob-num blob-num-replacement" else "blob-num")
<> td (mconcat . Vector.toList $ toMarkup <$> contents) ! A.class_ (stringValue $ if hasChanges then "blob-code blob-code-replacement" else "blob-code") <> string "\n"

4
src/Range.hs
View File

@ -11,6 +11,10 @@ import Data.Option
data Range = Range { start :: !Int, end :: !Int }
deriving (Eq, Show)
-- | Make a range at a given index.
rangeAt :: Int -> Range
rangeAt a = Range a a
-- | Return the length of the range.
rangeLength :: Range -> Int
rangeLength range = end range - start range

3
src/Renderer.hs
View File

@ -1,7 +1,8 @@
module Renderer where
import Data.Functor.Both
import Diff
import Source
-- | A function that will render a diff, given the two source files.
type Renderer a b = Diff a Info -> (SourceBlob, SourceBlob) -> b
type Renderer a b = Diff a Info -> Both SourceBlob -> b

13
src/Renderer/JSON.hs
View File

@ -10,6 +10,7 @@ import Control.Comonad.Cofree
import Control.Monad.Free
import Data.Aeson hiding (json)
import Data.ByteString.Lazy
import Data.Functor.Both
import Data.OrderedMap hiding (fromList)
import qualified Data.Text as T
import Data.Vector hiding (toList)
@ -24,8 +25,8 @@ import Syntax
import Term
-- | Render a diff to a string representing its JSON.
json :: ToJSON a => Renderer a ByteString
json diff (a, b) = encode $ object [ "rows" .= fst (splitDiffByLines diff (0, 0) (source a, source b)) ]
json :: Renderer a ByteString
json diff sources = encode $ object [ "rows" .= Prelude.fst (splitDiffByLines diff (pure 0) (source <$> sources)) ]
instance ToJSON Category where
toJSON (Other s) = String $ T.pack s
@ -33,18 +34,18 @@ instance ToJSON Category where
instance ToJSON Range where
toJSON (Range start end) = Array . fromList $ toJSON <$> [ start, end ]
instance ToJSON a => ToJSON (Row a) where
toJSON (Row left right) = Array . fromList $ toJSON . fromList . unLine <$> [ left, right ]
instance ToJSON leaf => ToJSON (SplitDiff leaf Info) where
toJSON (Row (Both (left, right))) = Array . fromList $ toJSON . fromList . unLine <$> [ left, right ]
instance ToJSON (SplitDiff leaf Info) where
toJSON (Free (Annotated (Info range categories) syntax)) = object [ "range" .= toJSON range, "categories" .= toJSON categories, "syntax" .= toJSON syntax ]
toJSON (Pure patch) = toJSON patch
instance ToJSON a => ToJSON (SplitPatch a) where
toJSON (SplitInsert a) = object [ "insert" .= toJSON a ]
toJSON (SplitDelete a) = object [ "delete" .= toJSON a ]
toJSON (SplitReplace a) = object [ "replace" .= toJSON a ]
instance (ToJSON leaf, ToJSON recur) => ToJSON (Syntax leaf recur) where
instance (ToJSON recur) => ToJSON (Syntax leaf recur) where
toJSON (Leaf _) = object [ "type" .= String "leaf" ]
toJSON (Indexed c) = object [ "type" .= String "indexed", "children" .= Array (fromList $ toJSON <$> c) ]
toJSON (Fixed c) = object [ "type" .= String "fixed", "children" .= Array (fromList $ toJSON <$> c) ]
toJSON (Keyed c) = object [ "type" .= String "fixed", "children" .= object (uncurry (.=) <$> toList c) ]
instance ToJSON leaf => ToJSON (Term leaf Info) where
instance ToJSON (Term leaf Info) where
toJSON (Info range categories :< syntax) = object [ "range" .= toJSON range, "categories" .= toJSON categories, "syntax" .= toJSON syntax ]

52
src/Renderer/Patch.hs
View File

@ -6,6 +6,8 @@ module Renderer.Patch (
import Alignment
import Diff
import Line
import Prelude hiding (fst, snd)
import qualified Prelude
import Range
import Renderer
import Row
@ -13,17 +15,16 @@ import Source hiding ((++), break)
import SplitDiff
import Control.Comonad.Cofree
import Control.Monad.Free
import Data.Functor.Both
import Data.Maybe
import Data.Monoid
import Data.Bifunctor
import Control.Monad
-- | Render a diff in the traditional patch format.
patch :: Renderer a String
patch diff sources = mconcat $ showHunk sources <$> hunks diff sources
-- | 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] }
data Hunk a = Hunk { offset :: Both (Sum Int), changes :: [Change a], trailingContext :: [Row a] }
deriving (Eq, Show)
-- | A change in a patch hunk, along with its preceding context.
@ -31,16 +32,16 @@ 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 a -> Both (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 a -> Both (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)
rowLength :: Row a -> Both (Sum Int)
rowLength = fmap lineLength . unRow
-- | The length of the line, being either 0 or 1.
lineLength :: Line a -> Sum Int
@ -48,13 +49,14 @@ lineLength EmptyLine = 0
lineLength _ = 1
-- | Given the before and after sources, render a hunk to a string.
showHunk :: (SourceBlob, SourceBlob) -> Hunk (SplitDiff a Info) -> String
showHunk blobs@(beforeBlob, afterBlob) hunk = header blobs hunk ++ concat (showChange sources <$> changes hunk) ++ showLines (snd sources) ' ' (unRight <$> trailingContext hunk)
where sources = (source beforeBlob, source afterBlob)
showHunk :: Both SourceBlob -> Hunk (SplitDiff a Info) -> String
showHunk blobs hunk = header blobs hunk ++ concat (showChange sources <$> changes hunk) ++ showLines (snd sources) ' ' (unRight <$> trailingContext hunk)
where sources = source <$> blobs
-- | 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)
showChange :: Both (Source Char) -> Change (SplitDiff a Info) -> String
showChange sources change = showLines (snd sources) ' ' (unRight <$> context change) ++ deleted ++ inserted
where (deleted, inserted) = runBoth $ pure showLines <*> sources <*> Both ('-', '+') <*> (pure fmap <*> Both (unLeft, unRight) <*> pure (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
@ -73,29 +75,29 @@ getRange (Free (Annotated (Info range _) _)) = range
getRange (Pure patch) = let Info range _ :< _ = getSplitTerm patch in range
-- | Returns the header given two source blobs and a hunk.
header :: (SourceBlob, SourceBlob) -> Hunk a -> String
header blobs hunk = "diff --git a/" ++ path (fst blobs) ++ " b/" ++ path (snd blobs) ++ "\n" ++
"index " ++ oid (fst blobs) ++ ".." ++ oid (snd blobs) ++ "\n" ++
header :: Both SourceBlob -> Hunk a -> String
header blobs hunk = "diff --git a/" ++ pathA ++ " b/" ++ pathB ++ "\n" ++
"index " ++ oidA ++ ".." ++ oidB ++ "\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
where (lengthA, lengthB) = runBoth . fmap getSum $ hunkLength hunk
(offsetA, offsetB) = runBoth . fmap getSum $ offset hunk
(pathA, pathB) = runBoth $ path <$> blobs
(oidA, oidB) = runBoth $ oid <$> blobs
-- | Render a diff as a series of hunks.
hunks :: Renderer a [Hunk (SplitDiff a Info)]
hunks diff (beforeBlob, afterBlob) = hunksInRows (1, 1) . fst $ splitDiffByLines diff (0, 0) (before, after)
where
before = source beforeBlob
after = source afterBlob
hunks diff blobs = hunksInRows (Both (1, 1)) . Prelude.fst $ splitDiffByLines diff (pure 0) (source <$> blobs)
-- | 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 :: Both (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 :: Both (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
Just (offset, change, rest) -> let (changes, rest') = contiguousChanges rest in Just (Hunk offset (change : changes) $ take 3 rest', drop 3 rest')
@ -107,7 +109,7 @@ nextHunk start rows = case nextChange start rows of
-- | 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 :: Both (Sum Int) -> [Row (SplitDiff a Info)] -> Maybe (Both (Sum Int), Change (SplitDiff a Info), [Row (SplitDiff a Info)])
nextChange start rows = case changeIncludingContext leadingContext afterLeadingContext of
Nothing -> Nothing
Just (change, afterChanges) -> Just (start <> mconcat (rowLength <$> skippedContext), change, afterChanges)
@ -125,7 +127,7 @@ changeIncludingContext leadingContext rows = case changes of
-- | Whether a row has changes on either side.
rowHasChanges :: Row (SplitDiff a Info) -> Bool
rowHasChanges (Row left right) = lineHasChanges left || lineHasChanges right
rowHasChanges (Row lines) = or (lineHasChanges <$> lines)
-- | Whether a line has changes.
lineHasChanges :: Line (SplitDiff a Info) -> Bool

85
src/Renderer/Split.hs
View File

@ -2,28 +2,30 @@
module Renderer.Split where
import Alignment
import Prelude hiding (div, head, span)
import Category
import Diff
import Line
import Row
import Renderer
import Term
import SplitDiff
import Syntax
import Control.Comonad.Cofree
import Range
import Control.Monad.Free
import Text.Blaze.Html
import Text.Blaze.Html5 hiding (map)
import qualified Text.Blaze.Internal as Blaze
import qualified Text.Blaze.Html5.Attributes as A
import Data.Foldable
import Data.Functor.Both
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Text.Blaze.Html.Renderer.Text
import Data.Foldable
import Data.Monoid
import Diff
import Line
import Prelude hiding (div, head, span, fst, snd)
import qualified Prelude
import Range
import Row
import Renderer
import Source hiding ((++))
import SplitDiff
import Syntax
import Term
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text
import Text.Blaze.Html5 hiding (map)
import qualified Text.Blaze.Html5.Attributes as A
import qualified Text.Blaze.Internal as Blaze
type ClassName = T.Text
@ -53,7 +55,7 @@ splitPatchToClassName patch = stringValue $ "patch " ++ case patch of
-- | Render a diff as an HTML split diff.
split :: Renderer leaf TL.Text
split diff (beforeBlob, afterBlob) = renderHtml
split diff blobs = renderHtml
. docTypeHtml
. ((head $ link ! A.rel "stylesheet" ! A.href "style.css") <>)
. body
@ -61,13 +63,12 @@ split diff (beforeBlob, afterBlob) = renderHtml
((colgroup $ (col ! A.width (stringValue . show $ columnWidth)) <> col <> (col ! A.width (stringValue . show $ columnWidth)) <> col) <>)
. mconcat $ numberedLinesToMarkup <$> reverse numbered
where
before = Source.source beforeBlob
after = Source.source afterBlob
rows = fst (splitDiffByLines diff (0, 0) (before, after))
sources = Source.source <$> blobs
rows = Prelude.fst (splitDiffByLines diff (pure 0) sources)
numbered = foldl' numberRows [] rows
maxNumber = case numbered of
[] -> 0
((x, _, y, _) : _) -> max x y
(row : _) -> runBothWith max $ Prelude.fst <$> row
-- | The number of digits in a number (e.g. 342 has 3 digits).
digits :: Int -> Int
@ -77,30 +78,27 @@ split diff (beforeBlob, afterBlob) = renderHtml
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"
numberedLinesToMarkup :: Both (Int, Line (SplitDiff a Info)) -> Markup
numberedLinesToMarkup numberedLines = tr $ (runBothWith (<>) (renderLine <$> numberedLines <*> sources)) <> string "\n"
renderable source = fmap (Renderable . (,) source)
renderLine :: (Int, Line (SplitDiff leaf Info)) -> Source Char -> Markup
renderLine (number, line) source = toMarkup $ Renderable (or $ hasChanges <$> line, number, Renderable . (,) source <$> line)
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 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
numberRows :: [Both (Int, Line a)] -> Row a -> [Both (Int, Line a)]
numberRows rows row = ((,) <$> ((+) <$> count rows <*> (valueOf <$> unRow row)) <*> unRow row) : rows
where count = maybe (pure 0) (fmap Prelude.fst) . maybeFirst
valueOf EmptyLine = 0
valueOf _ = 1
-- | Something that can be rendered as markup.
newtype Renderable a = Renderable (Source Char, a)
newtype Renderable a = Renderable a
instance ToMarkup f => ToMarkup (Renderable (Info, Syntax a (f, Range))) where
toMarkup (Renderable (source, (Info range categories, syntax))) = classifyMarkup categories $ case syntax of
instance ToMarkup f => ToMarkup (Renderable (Source Char, Info, Syntax a (f, Range))) where
toMarkup (Renderable (source, Info range categories, syntax)) = classifyMarkup categories $ case syntax of
Leaf _ -> span . string . toString $ slice range source
Indexed children -> ul . mconcat $ wrapIn li <$> contentElements children
Fixed children -> ul . mconcat $ wrapIn li <$> contentElements children
@ -117,11 +115,18 @@ instance ToMarkup f => ToMarkup (Renderable (Info, Syntax a (f, Range))) where
contentElements children = let (elements, previous) = foldl' markupForSeparatorAndChild ([], start range) children in
elements ++ [ string . toString $ slice (Range previous $ end range) source ]
instance ToMarkup (Renderable (Term a Info)) where
toMarkup (Renderable (source, term)) = fst $ cata (\ info@(Info range _) syntax -> (toMarkup $ Renderable (source, (info, syntax)), range)) term
instance ToMarkup (Renderable (Source Char, Term a Info)) where
toMarkup (Renderable (source, term)) = Prelude.fst $ cata (\ info@(Info range _) syntax -> (toMarkup $ Renderable (source, info, syntax), range)) term
instance ToMarkup (Renderable (SplitDiff a Info)) where
toMarkup (Renderable (source, diff)) = fst $ iter (\ (Annotated info@(Info range _) syntax) -> (toMarkup $ Renderable (source, (info, syntax)), range)) $ toMarkupAndRange <$> diff
instance ToMarkup (Renderable (Source Char, SplitDiff a Info)) where
toMarkup (Renderable (source, diff)) = Prelude.fst $ iter (\ (Annotated info@(Info range _) syntax) -> (toMarkup $ Renderable (source, info, syntax), range)) $ toMarkupAndRange <$> diff
where toMarkupAndRange :: SplitPatch (Term a Info) -> (Markup, Range)
toMarkupAndRange patch = let term@(Info range _ :< _) = getSplitTerm patch in
((div ! A.class_ (splitPatchToClassName patch) ! A.data_ (stringValue . show $ termSize term)) . toMarkup $ Renderable (source, term), range)
instance ToMarkup a => ToMarkup (Renderable (Bool, Int, Line a)) where
toMarkup (Renderable (_, _, EmptyLine)) = td mempty ! A.class_ (stringValue "blob-num blob-num-empty empty-cell") <> td mempty ! A.class_ (stringValue "blob-code blob-code-empty empty-cell") <> string "\n"
toMarkup (Renderable (hasChanges, num, line))
= td (string $ show num) ! A.class_ (stringValue $ if hasChanges then "blob-num blob-num-replacement" else "blob-num")
<> td (mconcat $ toMarkup <$> unLine line) ! A.class_ (stringValue $ if hasChanges then "blob-code blob-code-replacement" else "blob-code") <> string "\n"

51
src/Row.hs
View File

@ -1,42 +1,53 @@
module Row where
import Control.Arrow
import Data.Functor.Both as Both
import Line
import Prelude hiding (fst, snd)
-- | 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) }
newtype Row a = Row { unRow :: Both (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)
makeRow :: Line a -> Line a -> Row a
makeRow a = Row . both a
unLeft :: Row a -> Line a
unLeft = fst . unRow
unRight :: Row a -> Line a
unRight = snd . unRow
-- | 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)
wrapRowContents :: Both ([a] -> b) -> Row a -> Row b
wrapRowContents transform row = Row $ wrapLineContents <$> transform <*> unRow row
-- | 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]
adjoinRowsBy :: Both (MaybeOpen a) -> [Row a] -> Row a -> [Row a]
adjoinRowsBy _ [] row = [row]
adjoinRowsBy f g rows (Row left' right') | Just _ <- openLineBy f $ unLeft <$> rows, Just _ <- openLineBy g $ unRight <$> rows = zipWith Row (lefts left') (rights right')
where (lefts, rights) = adjoinLinesBy f *** adjoinLinesBy g $ unzip $ unRow <$> rows
adjoinRowsBy f rows (Row bothLines) | Both (Just _, Just _) <- openLineBy <$> f <*> (Both.unzip $ unRow <$> rows) = Both.zipWith makeRow $ both <*> bothLines
where both = adjoinLinesBy <$> f <*> (Both.unzip $ unRow <$> rows)
adjoinRowsBy f _ rows (Row left' right') | Just _ <- openLineBy f $ unLeft <$> rows = case right' of
adjoinRowsBy (Both (f, _)) rows (Row (Both (left', right'))) | Just _ <- openLineBy f $ unLeft <$> rows = case right' of
EmptyLine -> rest
_ -> Row EmptyLine right' : rest
where rest = zipWith Row (lefts left') rights
(lefts, rights) = first (adjoinLinesBy f) $ unzip $ unRow <$> rows
_ -> makeRow EmptyLine right' : rest
where rest = Prelude.zipWith makeRow (lefts left') rights
(lefts, rights) = first (adjoinLinesBy f) . runBoth $ Both.unzip $ unRow <$> rows
adjoinRowsBy _ g rows (Row left' right') | Just _ <- openLineBy g $ unRight <$> rows = case left' of
adjoinRowsBy (Both (_, g)) rows (Row (Both (left', right'))) | Just _ <- openLineBy g $ unRight <$> rows = case left' of
EmptyLine -> rest
_ -> Row left' EmptyLine : rest
where rest = zipWith Row lefts (rights right')
(lefts, rights) = second (adjoinLinesBy g) $ unzip $ unRow <$> rows
_ -> makeRow left' EmptyLine : rest
where rest = Prelude.zipWith makeRow lefts (rights right')
(lefts, rights) = second (adjoinLinesBy g) . runBoth $ Both.unzip $ unRow <$> rows
adjoinRowsBy _ _ rows row = row : rows
adjoinRowsBy _ rows row = row : rows
instance Show a => Show (Row a) where
show (Row left right) = "\n" ++ show left ++ " | " ++ show right
show (Row (Both (left, right))) = "\n" ++ show left ++ " | " ++ show right
instance Applicative Row where
pure = Row . pure . pure
Row (Both (f, g)) <*> Row (Both (a, b)) = Row $ both (f <*> a) (g <*> b)

15
src/Term.hs
View File

@ -1,8 +1,9 @@
module Term where
import Data.OrderedMap hiding (size)
import Data.Maybe
import Control.Comonad.Cofree
import Data.Functor.Both
import Data.Maybe
import Data.OrderedMap hiding (size)
import Syntax
-- | An annotated node (Syntax) in an abstract syntax tree.
@ -10,13 +11,13 @@ type Term a annotation = Cofree (Syntax a) annotation
-- | Zip two terms by combining their annotations into a pair of annotations.
-- | If the structure of the two terms don't match, then Nothing will be returned.
zipTerms :: Term a annotation -> Term a annotation -> Maybe (Term a (annotation, annotation))
zipTerms :: Term a annotation -> Term a annotation -> Maybe (Term a (Both annotation))
zipTerms (annotation1 :< a) (annotation2 :< b) = annotate $ zipUnwrap a b
where
annotate = fmap ((annotation1, annotation2) :<)
annotate = fmap (Both (annotation1, annotation2) :<)
zipUnwrap (Leaf _) (Leaf b') = Just $ Leaf b'
zipUnwrap (Indexed a') (Indexed b') = Just . Indexed . catMaybes $ zipWith zipTerms a' b'
zipUnwrap (Fixed a') (Fixed b') = Just . Fixed . catMaybes $ zipWith zipTerms a' b'
zipUnwrap (Indexed a') (Indexed b') = Just . Indexed . catMaybes $ Prelude.zipWith zipTerms a' b'
zipUnwrap (Fixed a') (Fixed b') = Just . Fixed . catMaybes $ Prelude.zipWith zipTerms a' b'
zipUnwrap (Keyed a') (Keyed b') | keys a' == keys b' = Just . Keyed . fromList . catMaybes $ zipUnwrapMaps a' b' <$> keys a'
zipUnwrap _ _ = Nothing
zipUnwrapMaps a' b' key = (,) key <$> zipTerms (a' ! key) (b' ! key)
@ -31,4 +32,4 @@ termSize = cata size where
size _ (Leaf _) = 1
size _ (Indexed i) = sum i
size _ (Fixed f) = sum f
size _ (Keyed k) = sum $ snd <$> toList k
size _ (Keyed k) = sum k

48
test/AlignmentSpec.hs
View File

@ -6,21 +6,26 @@ import Test.QuickCheck hiding (Fixed)
import Data.Text.Arbitrary ()
import Alignment
import ArbitraryTerm ()
import Control.Comonad.Cofree
import Control.Monad.Free hiding (unfold)
import Data.Functor.Both as Both
import Diff
import qualified Data.Maybe as Maybe
import Data.Functor.Identity
import Source hiding ((++))
import Line
import Prelude hiding (fst, snd)
import qualified Prelude
import Row
import Range
import Source hiding ((++))
import Syntax
import ArbitraryTerm ()
instance Arbitrary a => Arbitrary (Both a) where
arbitrary = pure (curry Both) <*> arbitrary <*> arbitrary
instance Arbitrary a => Arbitrary (Row a) where
arbitrary = oneof [
Row <$> arbitrary <*> arbitrary ]
arbitrary = Row <$> arbitrary
instance Arbitrary a => Arbitrary (Line a) where
arbitrary = oneof [
@ -39,42 +44,41 @@ spec = parallel $ do
describe "splitAnnotatedByLines" $ do
prop "outputs one row for single-line unchanged leaves" $
forAll (arbitraryLeaf `suchThat` isOnSingleLine) $
\ (source, info@(Info range categories), syntax) -> splitAnnotatedByLines (source, source) (range, range) (categories, categories) syntax `shouldBe` [
Row (makeLine [ Free $ Annotated info $ Leaf source ]) (makeLine [ Free $ Annotated info $ Leaf source ]) ]
\ (source, info@(Info range categories), syntax) -> splitAnnotatedByLines (pure source) (pure range) (pure categories) syntax `shouldBe` [
makeRow (makeLine [ Free $ Annotated info $ Leaf source ]) (makeLine [ Free $ Annotated info $ Leaf source ]) ]
prop "outputs one row for single-line empty unchanged indexed nodes" $
forAll (arbitrary `suchThat` (\ a -> filter (/= '\n') (toList a) == toList a)) $
\ source -> splitAnnotatedByLines (source, source) (getTotalRange source, getTotalRange source) (mempty, mempty) (Indexed [] :: Syntax String (Diff String Info)) `shouldBe` [
Row (makeLine [ Free $ Annotated (Info (getTotalRange source) mempty) $ Indexed [] ]) (makeLine [ Free $ Annotated (Info (getTotalRange source) mempty) $ Indexed [] ]) ]
\ source -> splitAnnotatedByLines (pure source) (pure (getTotalRange source)) (pure mempty) (Indexed [] :: Syntax String (Diff String Info)) `shouldBe` [
makeRow (makeLine [ Free $ Annotated (Info (getTotalRange source) mempty) $ Indexed [] ]) (makeLine [ Free $ Annotated (Info (getTotalRange source) mempty) $ Indexed [] ]) ]
prop "preserves line counts in equal sources" $
\ source ->
length (splitAnnotatedByLines (source, source) (getTotalRange source, getTotalRange source) (mempty, mempty) (Indexed . fst $ foldl combineIntoLeaves ([], 0) source)) `shouldBe` length (filter (== '\n') $ toList source) + 1
length (splitAnnotatedByLines (pure source) (pure (getTotalRange source)) (pure mempty) (Indexed . Prelude.fst $ foldl combineIntoLeaves ([], 0) source)) `shouldBe` length (filter (== '\n') $ toList source) + 1
prop "produces the maximum line count in inequal sources" $
\ sourceA sourceB ->
length (splitAnnotatedByLines (sourceA, sourceB) (getTotalRange sourceA, getTotalRange sourceB) (mempty, mempty) (Indexed $ zipWith (leafWithRangesInSources sourceA sourceB) (actualLineRanges (getTotalRange sourceA) sourceA) (actualLineRanges (getTotalRange sourceB) sourceB))) `shouldBe` max (length (filter (== '\n') $ toList sourceA) + 1) (length (filter (== '\n') $ toList sourceB) + 1)
\ sources ->
length (splitAnnotatedByLines sources (getTotalRange <$> sources) (pure mempty) (Indexed $ leafWithRangesInSources sources <$> Both.zip (actualLineRanges <$> (getTotalRange <$> sources) <*> sources))) `shouldBe` runBothWith max ((+ 1) . length . filter (== '\n') . toList <$> sources)
describe "adjoinRowsBy" $ do
prop "is identity on top of no rows" $
\ a -> adjoinRowsBy openMaybe openMaybe [] a == [ a ]
\ a -> adjoinRowsBy (pure openMaybe) [] a == [ a ]
prop "appends onto open rows" $
forAll ((arbitrary `suchThat` isOpenBy openMaybe) >>= \ a -> (,) a <$> (arbitrary `suchThat` isOpenBy openMaybe)) $
\ (a@(Row a1 b1), b@(Row a2 b2)) ->
adjoinRowsBy openMaybe openMaybe [ a ] b `shouldBe` [ Row (makeLine $ unLine a1 ++ unLine a2) (makeLine $ unLine b1 ++ unLine b2) ]
\ (a, b) -> adjoinRowsBy (pure openMaybe) [ a ] b `shouldBe` [ Row (mappend <$> unRow a <*> unRow b) ]
prop "does not append onto closed rows" $
forAll ((arbitrary `suchThat` isClosedBy openMaybe) >>= \ a -> (,) a <$> (arbitrary `suchThat` isClosedBy openMaybe)) $
\ (a, b) -> adjoinRowsBy openMaybe openMaybe [ a ] b `shouldBe` [ b, a ]
\ (a, b) -> adjoinRowsBy (pure openMaybe) [ a ] b `shouldBe` [ b, a ]
prop "does not promote elements through empty lines onto closed lines" $
forAll ((arbitrary `suchThat` isClosedBy openMaybe) >>= \ a -> (,) a <$> (arbitrary `suchThat` isClosedBy openMaybe)) $
\ (a, b) -> adjoinRowsBy openMaybe openMaybe [ Row EmptyLine EmptyLine, a ] b `shouldBe` [ b, Row EmptyLine EmptyLine, a ]
\ (a, b) -> adjoinRowsBy (pure openMaybe) [ makeRow EmptyLine EmptyLine, a ] b `shouldBe` [ b, makeRow EmptyLine EmptyLine, a ]
prop "promotes elements through empty lines onto open lines" $
forAll ((arbitrary `suchThat` isOpenBy openMaybe) >>= \ a -> (,) a <$> (arbitrary `suchThat` isOpenBy openMaybe)) $
\ (a, b) -> adjoinRowsBy openMaybe openMaybe [ Row EmptyLine EmptyLine, a ] b `shouldBe` Row EmptyLine EmptyLine : adjoinRowsBy openMaybe openMaybe [ a ] b
\ (a, b) -> adjoinRowsBy (pure openMaybe) [ makeRow EmptyLine EmptyLine, a ] b `shouldBe` makeRow EmptyLine EmptyLine : adjoinRowsBy (pure openMaybe) [ a ] b
describe "splitTermByLines" $ do
prop "preserves line count" $
@ -101,17 +105,17 @@ spec = parallel $ do
openTerm (fromList " \n") (Identity $ Info (Range 0 2) mempty :< Leaf "") `shouldBe` Nothing
where
isOpenBy f (Row a b) = Maybe.isJust (openLineBy f [ a ]) && Maybe.isJust (openLineBy f [ b ])
isClosedBy f (Row a@(Line _) b@(Line _)) = Maybe.isNothing (openLineBy f [ a ]) && Maybe.isNothing (openLineBy f [ b ])
isClosedBy _ (Row _ _) = False
isOpenBy f (Row lines) = and (Maybe.isJust . openLineBy f . pure <$> lines)
isClosedBy f (Row lines@(Both (Line _, Line _))) = and (Maybe.isNothing . openLineBy f . pure <$> lines)
isClosedBy _ _ = False
isOnSingleLine (a, _, _) = filter (/= '\n') (toList a) == toList a
getTotalRange (Source vector) = Range 0 $ length vector
combineIntoLeaves (leaves, start) char = (leaves ++ [ Free $ Annotated (Info (Range start $ start + 1) mempty, Info (Range start $ start + 1) mempty) (Leaf [ char ]) ], start + 1)
combineIntoLeaves (leaves, start) char = (leaves ++ [ Free $ Annotated (Info <$> (pure (Range start $ start + 1)) <*> mempty) (Leaf [ char ]) ], start + 1)
leafWithRangesInSources sourceA sourceB rangeA rangeB = Free $ Annotated (Info rangeA mempty, Info rangeB mempty) (Leaf $ toList sourceA ++ toList sourceB)
leafWithRangesInSources sources ranges = Free $ Annotated (Info <$> ranges <*> pure mempty) (Leaf $ toList (fst sources) ++ toList (snd sources))
openMaybe :: Maybe Bool -> Maybe (Maybe Bool)
openMaybe (Just a) = Just (Just a)

51
test/CorpusSpec.hs
View File

@ -6,9 +6,8 @@ import qualified Renderer.JSON as J
import qualified Renderer.Patch as P
import qualified Renderer.Split as Split
import qualified Source as S
import Control.DeepSeq
import Data.Bifunctor.Join
import Data.Functor.Both
import qualified Data.ByteString.Lazy.Char8 as B
import Data.List as List
import Data.Map as Map
@ -16,6 +15,9 @@ import Data.Maybe
import Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Prelude hiding (fst, snd)
import qualified Prelude
import qualified Source as S
import System.FilePath
import System.FilePath.Glob
import Test.Hspec
@ -23,36 +25,36 @@ import Test.Hspec
spec :: Spec
spec = parallel $ do
-- describe "crashers crash" $ runTestsIn "test/crashers-todo/" ((`shouldThrow` anyException) . return)
describe "crashers should not crash" $ runTestsIn "test/crashers/" (uncurry shouldBe)
describe "todos are incorrect" $ runTestsIn "test/diffs-todo/" (uncurry shouldNotBe)
describe "should produce the correct diff" $ runTestsIn "test/diffs/" (uncurry shouldBe)
describe "crashers should not crash" $ runTestsIn "test/crashers/" shouldBe
describe "todos are incorrect" $ runTestsIn "test/diffs-todo/" shouldNotBe
describe "should produce the correct diff" $ runTestsIn "test/diffs/" shouldBe
it "lists example fixtures" $ do
examples "test/crashers/" `shouldNotReturn` []
examples "test/diffs/" `shouldNotReturn` []
where
runTestsIn :: String -> ((String, String) -> Expectation) -> SpecWith ()
runTestsIn :: String -> (String -> String -> Expectation) -> SpecWith ()
runTestsIn directory matcher = do
paths <- runIO $ examples directory
let tests = correctTests =<< paths
mapM_ (\ (formatName, renderer, a, b, output) -> it (normalizeName a ++ " (" ++ formatName ++ ")") $ testDiff renderer a b output matcher) tests
mapM_ (\ (formatName, renderer, paths, output) -> it (normalizeName (fst paths) ++ " (" ++ formatName ++ ")") $ testDiff renderer paths output matcher) tests
correctTests :: (FilePath, FilePath, Maybe FilePath, Maybe FilePath, Maybe FilePath) -> [(String, Renderer T.Text String, FilePath, FilePath, Maybe FilePath)]
correctTests paths@(_, _, Nothing, Nothing, Nothing) = testsForPaths paths
correctTests paths = List.filter (\(_, _, _, _, output) -> isJust output) $ testsForPaths paths
testsForPaths :: (FilePath, FilePath, Maybe FilePath, Maybe FilePath, Maybe FilePath) -> [(String, Renderer T.Text String, FilePath, FilePath, Maybe FilePath)]
testsForPaths (a, b, json, patch, split) = [ ("json", testJSON, a, b, json), ("patch", P.patch, a, b, patch), ("split", testSplit, a, b, split) ]
testSplit :: Renderer T.Text String
correctTests :: (Both FilePath, Maybe FilePath, Maybe FilePath, Maybe FilePath) -> [(String, Renderer a String, Both FilePath, Maybe FilePath)]
correctTests paths@(_, Nothing, Nothing, Nothing) = testsForPaths paths
correctTests paths = List.filter (\(_, _, _, output) -> isJust output) $ testsForPaths paths
testsForPaths :: (Both FilePath, Maybe FilePath, Maybe FilePath, Maybe FilePath) -> [(String, Renderer a String, Both FilePath, Maybe FilePath)]
testsForPaths (paths, json, patch, split) = [ ("json", testJSON, paths, json), ("patch", P.patch, paths, patch), ("split", testSplit, paths, split) ]
testSplit :: Renderer a String
testSplit diff sources = TL.unpack $ Split.split diff sources
testJSON :: Renderer T.Text String
testJSON :: Renderer a String
testJSON diff sources = B.unpack $ J.json diff sources
-- | Return all the examples from the given directory. Examples are expected to
-- | have the form "foo.A.js", "foo.B.js", "foo.patch.js". Diffs are not
-- | required as the test may be verifying that the inputs don't crash.
examples :: FilePath -> IO [(FilePath, FilePath, Maybe FilePath, Maybe FilePath, Maybe FilePath)]
examples :: FilePath -> IO [(Both FilePath, Maybe FilePath, Maybe FilePath, Maybe FilePath)]
examples directory = do
as <- toDict <$> globFor "*.A.*"
bs <- toDict <$> globFor "*.B.*"
@ -60,11 +62,11 @@ examples directory = do
patches <- toDict <$> globFor "*.patch.*"
splits <- toDict <$> globFor "*.split.*"
let keys = Set.unions $ keysSet <$> [as, bs]
return $ (\name -> (as ! name, bs ! name, Map.lookup name jsons, Map.lookup name patches, Map.lookup name splits)) <$> sort (Set.toList keys)
return $ (\name -> (Both (as ! name, bs ! name), Map.lookup name jsons, Map.lookup name patches, Map.lookup name splits)) <$> sort (Set.toList keys)
where
globFor :: String -> IO [FilePath]
globFor p = globDir1 (compile p) directory
toDict list = Map.fromList ((normalizeName <$> list) `zip` list)
toDict list = Map.fromList ((normalizeName <$> list) `Prelude.zip` list)
-- | Given a test name like "foo.A.js", return "foo.js".
normalizeName :: FilePath -> FilePath
@ -73,15 +75,14 @@ normalizeName path = addExtension (dropExtension $ dropExtension path) (takeExte
-- | Given file paths for A, B, and, optionally, a diff, return whether diffing
-- | the files will produce the diff. If no diff is provided, then the result
-- | is true, but the diff will still be calculated.
testDiff :: Renderer T.Text String -> FilePath -> FilePath -> Maybe FilePath -> ((String, String) -> Expectation) -> Expectation
testDiff renderer a b diff matcher = do
let parser = parserForFilepath a
sources <- sequence $ readAndTranscodeFile <$> Join (a, b)
let srcs = runJoin sources
let sourceBlobs = (S.SourceBlob (fst srcs) mempty a, S.SourceBlob (snd srcs) mempty b)
testDiff :: Renderer T.Text String -> Both FilePath -> Maybe FilePath -> (String -> String -> Expectation) -> Expectation
testDiff renderer paths diff matcher = do
let parser = parserForFilepath (fst paths)
sources <- sequence $ readAndTranscodeFile <$> paths
let sourceBlobs = Both (S.SourceBlob, S.SourceBlob) <*> sources <*> pure mempty <*> paths
actual <- diffFiles parser renderer sourceBlobs
case diff of
Nothing -> actual `deepseq` matcher (actual, actual)
Nothing -> actual `deepseq` matcher actual actual
Just file -> do
expected <- readFile file
matcher (actual, expected)
matcher actual expected

3
test/PatchOutputSpec.hs
View File

@ -1,5 +1,6 @@
module PatchOutputSpec where
import Data.Functor.Both
import Diff
import Renderer.Patch
import Range
@ -12,4 +13,4 @@ spec :: Spec
spec = parallel $
describe "hunks" $
it "empty diffs have no hunks" $
hunks (Free . Annotated (Info (Range 0 0) mempty, Info (Range 0 0) mempty) $ Leaf "") (SourceBlob (fromList "") "abcde" "path2.txt", SourceBlob (fromList "") "xyz" "path2.txt") `shouldBe` []
hunks (Free . Annotated (pure (Info (Range 0 0) mempty)) $ Leaf "") (Both (SourceBlob (fromList "") "abcde" "path2.txt", SourceBlob (fromList "") "xyz" "path2.txt")) `shouldBe` []