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

Merge pull request #637 from github/generalize-all-the-things!

Browse Source 
Generalize all the things!
This commit is contained in:
Josh Vera 2016-07-15 11:32:13 -04:00 committed by GitHub
commit 6fa57a5e58
16 changed files with 114 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/Alignment.hs
View File

@ -23,7 +23,6 @@ import Diff
import Info
import Patch
import Prologue hiding (fst, snd)
import qualified Prologue
import Range
import Source hiding (break, fromList, uncons, (++))
import SplitDiff
@ -43,11 +42,11 @@ hasChanges :: SplitDiff leaf annotation -> Bool
hasChanges = or . (True <$)
-- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side.
alignDiff :: (Show leaf, Show (Record fields), HasField fields Range) => Both (Source Char) -> Diff leaf (Record fields) -> [Join These (SplitDiff leaf (Record fields))]
alignDiff sources diff = iter (alignSyntax (runBothWith ((Join .) . These)) (free . Free) getRange sources) (alignPatch sources <$> diff)
alignDiff :: HasField fields Range => Both (Source Char) -> Diff leaf (Record fields) -> [Join These (SplitDiff leaf (Record fields))]
alignDiff sources diff = iter (alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources) (alignPatch sources <$> diff)
-- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff.
alignPatch :: forall fields leaf. (Show leaf, Show (Record fields), HasField fields Range) => Both (Source Char) -> Patch (Term leaf (Record fields)) -> [Join These (SplitDiff leaf (Record fields))]
alignPatch :: forall fields leaf. HasField fields Range => Both (Source Char) -> Patch (Term leaf (Record fields)) -> [Join These (SplitDiff leaf (Record fields))]
alignPatch sources patch = case patch of
Delete term -> fmap (pure . SplitDelete) <$> alignSyntax' this (fst sources) term
Insert term -> fmap (pure . SplitInsert) <$> alignSyntax' that (snd sources) term
@ -61,7 +60,7 @@ alignPatch sources patch = case patch of
that = Join . That . runIdentity
-- | The Applicative instance f is either Identity or Both. Identity is for Terms in Patches, Both is for Diffs in unchanged portions of the diff.
alignSyntax :: (Applicative f, Show term, HasField fields Range) => (forall a. f a -> Join These a) -> (CofreeF (Syntax leaf) (Record fields) term -> term) -> (term -> Range) -> f (Source Char) -> CofreeF (Syntax leaf) (f (Record fields)) [Join These term] -> [Join These term]
alignSyntax :: (Applicative f, HasField fields Range) => (forall a. f a -> Join These a) -> (CofreeF (Syntax leaf) (Record fields) term -> term) -> (term -> Range) -> f (Source Char) -> CofreeF (Syntax leaf) (f (Record fields)) [Join These term] -> [Join These term]
alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = case syntax of
Leaf s -> catMaybes $ wrapInBranch (const (Leaf s)) . fmap (flip (,) []) <$> sequenceL lineRanges
Indexed children -> catMaybes $ wrapInBranch Indexed <$> alignBranch getRange (join children) bothRanges
@ -69,10 +68,9 @@ alignSyntax toJoinThese toNode getRange sources (infos :< syntax) = case syntax
where bothRanges = modifyJoin (fromThese [] []) lineRanges
lineRanges = toJoinThese $ actualLineRanges <$> (characterRange <$> infos) <*> sources
wrapInBranch constructor = applyThese $ toJoinThese ((\ info (range, children) -> toNode (setCharacterRange info range :< constructor children)) <$> infos)
pairWithKey (key, values) = fmap ((,) key) <$> values
-- | Given a function to get the range, a list of already-aligned children, and the lists of ranges spanned by a branch, return the aligned lines.
alignBranch :: Show term => (term -> Range) -> [Join These term] -> Both [Range] -> [Join These (Range, [term])]
alignBranch :: (term -> Range) -> [Join These term] -> Both [Range] -> [Join These (Range, [term])]
-- There are no more ranges, so we’re done.
alignBranch _ _ (Join ([], [])) = []
-- There are no more children, so we can just zip the remaining ranges together.

8
src/DiffOutput.hs
View File

@ -1,10 +1,14 @@
module DiffOutput where
import Category
import Prologue
import qualified Data.Text.IO as TextIO
import Data.Functor.Both
import Data.Record
import Diffing
import Info
import Parser
import Range
import qualified Renderer.JSON as J
import qualified Renderer.Patch as P
import qualified Renderer.Summary as S
@ -16,7 +20,7 @@ import System.FilePath
import qualified System.IO as IO
-- | Returns a rendered diff given a parser, diff arguments and two source blobs.
textDiff :: Parser -> DiffArguments -> Both SourceBlob -> IO Text
textDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range, HasField fields Size) => Parser fields -> DiffArguments -> Both SourceBlob -> IO Text
textDiff parser arguments sources = case format arguments of
Split -> diffFiles parser split sources
Patch -> diffFiles parser P.patch sources
@ -32,7 +36,7 @@ truncatedDiff arguments sources = case format arguments of
Summary -> pure ""
-- | Prints a rendered diff to stdio or a filepath given a parser, diff arguments and two source blobs.
printDiff :: Parser -> DiffArguments -> Both SourceBlob -> IO ()
printDiff :: (Eq (Record fields), HasField fields Category, HasField fields Cost, HasField fields Range, HasField fields Size) => Parser fields -> DiffArguments -> Both SourceBlob -> IO ()
printDiff parser arguments sources = case format arguments of
Split -> put (output arguments) =<< diffFiles parser split sources
where

11
src/DiffSummary.hs
View File

@ -5,18 +5,19 @@ import Prologue hiding (fst, snd)
import Data.String
import Data.Maybe (fromJust)
import Diff
import Info (Info, category)
import Info (category)
import Patch
import Term
import Syntax
import Category
import Data.Functor.Foldable as Foldable
import Data.Functor.Both
import Data.Record
import Data.Text as Text (unpack)
data DiffInfo = DiffInfo { categoryName :: String, termName :: Maybe String } deriving (Eq, Show)
maybeTermName :: HasCategory leaf => Term leaf Info -> Maybe String
maybeTermName :: (HasCategory leaf, HasField fields Category) => Term leaf (Record fields) -> Maybe String
maybeTermName term = case runCofree term of
(_ :< Leaf leaf) -> Just (toCategoryName leaf)
(_ :< Indexed children) -> toCategoryName . category <$> head (extract <$> children)
@ -45,7 +46,7 @@ instance HasCategory Category where
ArrayLiteral -> "array"
Other s -> s
instance HasCategory leaf => HasCategory (Term leaf Info) where
instance (HasCategory leaf, HasField fields Category) => HasCategory (Term leaf (Record fields)) where
toCategoryName = toCategoryName . category . extract
data DiffSummary a = DiffSummary {
@ -66,9 +67,9 @@ instance Show (DiffSummary DiffInfo) where
then ""
else " in the " ++ intercalate "/" (categoryName <$> parentAnnotations) ++ " context"
diffSummary :: HasCategory leaf => Diff leaf Info -> [DiffSummary DiffInfo]
diffSummary :: (HasCategory leaf, HasField fields Category) => Diff leaf (Record fields) -> [DiffSummary DiffInfo]
diffSummary = cata diffSummary' where
diffSummary' :: HasCategory leaf => Base (Diff leaf Info) [DiffSummary DiffInfo] -> [DiffSummary DiffInfo]
diffSummary' :: (HasCategory leaf, HasField fields Category) => Base (Diff leaf (Record fields)) [DiffSummary DiffInfo] -> [DiffSummary DiffInfo]
diffSummary' (Free (_ :< Leaf _)) = [] -- Skip leaves since they don't have any changes
diffSummary' (Free (infos :< Indexed children)) = prependSummary (DiffInfo (toCategoryName . category $ snd infos) Nothing) <$> join children
diffSummary' (Free (infos :< Fixed children)) = prependSummary (DiffInfo (toCategoryName . category $ snd infos) Nothing) <$> join children

23
src/Diffing.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
module Diffing where
import Prologue hiding (fst, snd)
@ -26,7 +27,7 @@ import TreeSitter
import Text.Parser.TreeSitter.Language
-- | Return a parser based on the file extension (including the ".").
parserForType :: T.Text -> Parser
parserForType :: T.Text -> Parser '[Range, Category, Size, Cost]
parserForType mediaType = case languageForType mediaType of
Just C -> treeSitterParser C ts_language_c
Just JavaScript -> treeSitterParser JavaScript ts_language_javascript
@ -34,7 +35,7 @@ parserForType mediaType = case languageForType mediaType of
_ -> lineByLineParser
-- | A fallback parser that treats a file simply as rows of strings.
lineByLineParser :: Parser
lineByLineParser :: Parser '[Range, Category, Size, Cost]
lineByLineParser input = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of
(leaves, _) -> cofree <$> leaves
where
@ -43,19 +44,18 @@ lineByLineParser input = pure . cofree . root $ case foldl' annotateLeaves ([],
((Range 0 $ length input) .: Other "program" .: size .: Cost (unSize size) .: RNil) :< Indexed children
leaf charIndex line = ((Range charIndex $ charIndex + T.length line) .: Other "program" .: 1 .: 1 .: RNil) :< Leaf line
annotateLeaves (accum, charIndex) line =
(accum ++ [ leaf charIndex (toText line) ]
(accum <> [ leaf charIndex (toText line) ]
, charIndex + length line)
toText = T.pack . Source.toString
-- | Return the parser that should be used for a given path.
parserForFilepath :: FilePath -> Parser
parserForFilepath :: FilePath -> Parser '[Range, Category, Size, Cost]
parserForFilepath = parserForType . T.pack . takeExtension
-- | Replace every string leaf with leaves of the words in the string.
breakDownLeavesByWord :: Source Char -> Term T.Text Info -> Term T.Text Info
breakDownLeavesByWord :: (HasField fields Cost, HasField fields Range, HasField fields Size) => Source Char -> Term T.Text (Record fields) -> Term T.Text (Record fields)
breakDownLeavesByWord source = cata replaceIn
where
replaceIn :: TermF T.Text Info (Term T.Text Info) -> Term T.Text Info
replaceIn (info :< syntax) = let size' = 1 + sum (size . extract <$> syntax') in cofree $ setCost (setSize info size') (Cost (unSize size')) :< syntax'
where syntax' = case (ranges, syntax) of
(_:_:_, Leaf _) -> Indexed (makeLeaf info <$> ranges)
@ -81,7 +81,7 @@ readAndTranscodeFile path = do
-- | result.
-- | Returns the rendered result strictly, so it's always fully evaluated
-- | with respect to other IO actions.
diffFiles :: Parser -> Renderer -> Both SourceBlob -> IO T.Text
diffFiles :: (HasField fields Category, HasField fields Cost, HasField fields Range, HasField fields Size, Eq (Record fields)) => Parser fields -> Renderer (Record fields) -> Both SourceBlob -> IO T.Text
diffFiles parser renderer sourceBlobs = do
let sources = source <$> sourceBlobs
terms <- sequence $ parser <$> sources
@ -91,11 +91,10 @@ diffFiles parser renderer sourceBlobs = do
let textDiff = case areNullOids of
(True, False) -> pure $ Insert (snd terms)
(False, True) -> pure $ Delete (fst terms)
(_, _) -> runBothWith (diffTerms construct shouldCompareTerms diffCostWithCachedTermSizes) $ replaceLeaves <*> terms
(_, _) -> runBothWith (diffTerms construct shouldCompareTerms diffCostWithCachedTermCosts) $ replaceLeaves <*> terms
pure $! renderer textDiff sourceBlobs
where construct :: CofreeF (Syntax Text) (Both Info) (Diff Text Info) -> Diff Text Info
construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax))
where construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax))
sumCost = fmap getSum . foldMap (fmap Sum . getCost)
getCost diff = case runFree diff of
Free (info :< _) -> cost <$> info
@ -103,7 +102,7 @@ diffFiles parser renderer sourceBlobs = do
shouldCompareTerms = (==) `on` category . extract
-- | The sum of the node count of the diff’s patches.
diffCostWithCachedTermSizes :: Diff a Info -> Integer
diffCostWithCachedTermSizes diff = unCost $ case runFree diff of
diffCostWithCachedTermCosts :: HasField fields Cost => Diff leaf (Record fields) -> Integer
diffCostWithCachedTermCosts diff = unCost $ case runFree diff of
Free (info :< _) -> sum (cost <$> info)
Pure patch -> sum (cost . extract <$> patch)

4
src/Info.hs
View File

@ -12,10 +12,6 @@ newtype Size = Size { unSize :: Integer }
newtype Cost = Cost { unCost :: Integer }
deriving (Eq, Num, Ord, Show)
type InfoFields = '[ Range, Category, Size, Cost ]
type Info = Record InfoFields
characterRange :: HasField fields Range => Record fields -> Range
characterRange = getField

6
src/Interpreter.hs
View File

@ -25,11 +25,11 @@ type Comparable leaf annotation = Term leaf annotation -> Term leaf annotation -
type DiffConstructor leaf annotation = CofreeF (Syntax leaf) (Both annotation) (Diff leaf annotation) -> Diff leaf annotation
-- | Diff two terms, given a function that determines whether two terms can be compared and a cost function.
diffTerms :: (Eq leaf, Hashable leaf, Ord (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Diff leaf (Record fields)
diffTerms :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Diff leaf (Record fields)
diffTerms construct comparable cost a b = fromMaybe (pure $ Replace a b) $ constructAndRun construct comparable cost a b
-- | Constructs an algorithm and runs it
constructAndRun :: (Eq leaf, Hashable leaf, Ord (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields))
constructAndRun :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Term leaf (Record fields) -> Term leaf (Record fields) -> Maybe (Diff leaf (Record fields))
constructAndRun construct comparable cost t1 t2
| not $ comparable t1 t2 = Nothing
| (category <$> t1) == (category <$> t2) = hylo construct runCofree <$> zipTerms t1 t2
@ -42,7 +42,7 @@ constructAndRun construct comparable cost t1 t2
annotate = pure . construct . (both annotation1 annotation2 :<)
-- | Runs the diff algorithm
run :: (Eq leaf, Hashable leaf, Ord (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm leaf (Record fields) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields))
run :: (Eq leaf, Hashable leaf, Eq (Record fields), HasField fields Category) => DiffConstructor leaf (Record fields) -> Comparable leaf (Record fields) -> SES.Cost (Diff leaf (Record fields)) -> Algorithm leaf (Record fields) (Diff leaf (Record fields)) -> Maybe (Diff leaf (Record fields))
run construct comparable cost algorithm = case runFree algorithm of
Pure diff -> Just diff
Free (Recursive t1 t2 f) -> run construct comparable cost . f $ recur a b where

10
src/Parser.hs
View File

@ -1,9 +1,11 @@
module Parser where
import Prologue hiding (Constructor)
import Data.Record
import Data.Text (pack)
import Category
import Info
import Range
import Syntax
import Term
import qualified Data.Set as Set
@ -12,10 +14,7 @@ import Source
-- | A function that takes a source file and returns an annotated AST.
-- | The return is in the IO monad because some of the parsers are written in C
-- | and aren't pure.
type Parser = Source Char -> IO (Term Text Info)
-- | A function which constructs a term from a source string, annotation, and children.
type Constructor = Source Char -> Info -> [Term Text Info] -> Term Text Info
type Parser fields = Source Char -> IO (Term Text (Record fields))
-- | Categories that are treated as fixed nodes.
fixedCategories :: Set.Set Category
@ -27,11 +26,10 @@ isFixed = flip Set.member fixedCategories
-- | Given a function that maps production names to sets of categories, produce
-- | a Constructor.
termConstructor :: Constructor
termConstructor :: (HasField fields Category, HasField fields Range) => Source Char -> (Record fields) -> [Term Text (Record fields)] -> Term Text (Record fields)
termConstructor source info children = cofree (info :< syntax)
where
syntax = construct children
construct :: [Term Text Info] -> Syntax Text (Term Text Info)
construct [] = Leaf . pack . toString $ slice (characterRange info) source
construct children | isFixed (category info) = Fixed children
construct children = Indexed children

3
src/Renderer.hs
View File

@ -3,11 +3,10 @@ module Renderer where
import Prologue
import Data.Functor.Both
import Diff
import Info
import Source
-- | A function that will render a diff, given the two source files.
type Renderer = Diff Text Info -> Both SourceBlob -> Text
type Renderer annotation = Diff Text annotation -> Both SourceBlob -> Text
data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath, outputPath :: FilePath }
deriving (Show)

15
src/Renderer/JSON.hs
View File

@ -10,6 +10,7 @@ import Category
import Data.Aeson hiding (json)
import Data.Bifunctor.Join
import Data.ByteString.Builder
import Data.Record
import qualified Data.Text as T
import Data.These
import Data.Vector hiding (toList)
@ -22,13 +23,13 @@ import Syntax
import Term
-- | Render a diff to a string representing its JSON.
json :: Renderer
json :: (HasField fields Category, HasField fields Range) => Renderer (Record fields)
json diff sources = toS . toLazyByteString . fromEncoding . pairs $ "rows" .= annotateRows (alignDiff (source <$> sources) diff) <> "oids" .= (oid <$> sources) <> "paths" .= (path <$> sources)
where annotateRows = fmap (fmap NumberedLine) . numberedRows
newtype NumberedLine a = NumberedLine (Int, a)
instance ToJSON (NumberedLine (SplitDiff leaf Info)) where
instance (HasField fields Category, HasField fields Range) => ToJSON (NumberedLine (SplitDiff leaf (Record fields))) where
toJSON (NumberedLine (n, a)) = object (lineFields n a (getRange a))
toEncoding (NumberedLine (n, a)) = pairs $ mconcat (lineFields n a (getRange a))
instance ToJSON Category where
@ -43,32 +44,32 @@ instance ToJSON a => ToJSON (Join These a) where
instance ToJSON a => ToJSON (Join (,) a) where
toJSON (Join (a, b)) = Array . fromList $ toJSON <$> [ a, b ]
toEncoding = foldable
instance ToJSON (SplitDiff leaf Info) where
instance (HasField fields Category, HasField fields Range) => ToJSON (SplitDiff leaf (Record fields)) where
toJSON splitDiff = case runFree splitDiff of
(Free (info :< syntax)) -> object (termFields info syntax)
(Pure patch) -> object (patchFields patch)
toEncoding splitDiff = case runFree splitDiff of
(Free (info :< syntax)) -> pairs $ mconcat (termFields info syntax)
(Pure patch) -> pairs $ mconcat (patchFields patch)
instance ToJSON (Term leaf Info) where
instance (HasField fields Category, HasField fields Range) => ToJSON (Term leaf (Record fields)) where
toJSON term | (info :< syntax) <- runCofree term = object (termFields info syntax)
toEncoding term | (info :< syntax) <- runCofree term = pairs $ mconcat (termFields info syntax)
lineFields :: KeyValue kv => Int -> SplitDiff leaf Info -> Range -> [kv]
lineFields :: (HasField fields Category, HasField fields Range) => KeyValue kv => Int -> SplitDiff leaf (Record fields) -> Range -> [kv]
lineFields n term range = [ "number" .= n
, "terms" .= [ term ]
, "range" .= range
, "hasChanges" .= hasChanges term
]
termFields :: (ToJSON recur, KeyValue kv) => Info -> Syntax leaf recur -> [kv]
termFields :: (ToJSON recur, KeyValue kv, HasField fields Category, HasField fields Range) => Record fields -> Syntax leaf recur -> [kv]
termFields info syntax = "range" .= characterRange info : "category" .= category info : case syntax of
Leaf _ -> []
Indexed c -> childrenFields c
Fixed c -> childrenFields c
where childrenFields c = [ "children" .= c ]
patchFields :: KeyValue kv => SplitPatch (Term leaf Info) -> [kv]
patchFields :: (KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (Term leaf (Record fields)) -> [kv]
patchFields patch = case patch of
SplitInsert term -> fields "insert" term
SplitDelete term -> fields "delete" term

65
src/Renderer/Patch.hs
View File

@ -9,27 +9,28 @@ import Alignment
import Data.Bifunctor.Join
import Data.Functor.Both as Both
import Data.List (span, unzip)
import Data.Record
import Data.String
import Data.Text (pack)
import Data.These
import Diff
import Info
import Patch
import Prologue hiding (fst, snd)
import Range
import Renderer
import Source hiding ((++), break)
import Source hiding (break)
import SplitDiff
-- | Render a timed out file as a truncated diff.
truncatePatch :: DiffArguments -> Both SourceBlob -> Text
truncatePatch _ blobs = pack $ header blobs ++ "#timed_out\nTruncating diff: timeout reached.\n"
truncatePatch _ blobs = pack $ header blobs <> "#timed_out\nTruncating diff: timeout reached.\n"
-- | Render a diff in the traditional patch format.
patch :: Renderer
patch :: HasField fields Range => Renderer (Record fields)
patch diff blobs = pack $ case getLast (foldMap (Last . Just) string) of
Just c | c /= '\n' -> string ++ "\n\\ No newline at end of file\n"
Just c | c /= '\n' -> string <> "\n\\ No newline at end of file\n"
_ -> string
where string = header blobs ++ mconcat (showHunk blobs <$> hunks diff blobs)
where string = header blobs <> mconcat (showHunk blobs <$> hunks diff blobs)
-- | A hunk in a patch, including the offset, changes, and context.
data Hunk a = Hunk { offset :: Both (Sum Int), changes :: [Change a], trailingContext :: [Join These a] }
@ -52,65 +53,65 @@ rowIncrement :: Join These a -> Both (Sum Int)
rowIncrement = Join . fromThese (Sum 0) (Sum 0) . runJoin . (Sum 1 <$)
-- | Given the before and after sources, render a hunk to a string.
showHunk :: Both SourceBlob -> Hunk (SplitDiff a Info) -> String
showHunk blobs hunk = maybeOffsetHeader ++
concat (showChange sources <$> changes hunk) ++
showHunk :: HasField fields Range => Both SourceBlob -> Hunk (SplitDiff a (Record fields)) -> String
showHunk blobs hunk = maybeOffsetHeader <>
concat (showChange sources <$> changes hunk) <>
showLines (snd sources) ' ' (maybeSnd . runJoin <$> trailingContext hunk)
where sources = source <$> blobs
maybeOffsetHeader = if lengthA > 0 && lengthB > 0
then offsetHeader
else mempty
offsetHeader = "@@ -" ++ offsetA ++ "," ++ show lengthA ++ " +" ++ offsetB ++ "," ++ show lengthB ++ " @@" ++ "\n"
offsetHeader = "@@ -" <> offsetA <> "," <> show lengthA <> " +" <> offsetB <> "," <> show lengthB <> " @@" <> "\n"
(lengthA, lengthB) = runJoin . fmap getSum $ hunkLength hunk
(offsetA, offsetB) = runJoin . fmap (show . getSum) $ offset hunk
-- | Given the before and after sources, render a change to a string.
showChange :: Both (Source Char) -> Change (SplitDiff a Info) -> String
showChange sources change = showLines (snd sources) ' ' (maybeSnd . runJoin <$> context change) ++ deleted ++ inserted
showChange :: HasField fields Range => Both (Source Char) -> Change (SplitDiff a (Record fields)) -> String
showChange sources change = showLines (snd sources) ' ' (maybeSnd . runJoin <$> context change) <> deleted <> inserted
where (deleted, inserted) = runJoin $ pure showLines <*> sources <*> both '-' '+' <*> Join (unzip (fromThese Nothing Nothing . runJoin . fmap Just <$> contents change))
-- | Given a source, render a set of lines to a string with a prefix.
showLines :: Source Char -> Char -> [Maybe (SplitDiff leaf Info)] -> String
showLines :: HasField fields Range => Source Char -> Char -> [Maybe (SplitDiff leaf (Record fields))] -> String
showLines source prefix lines = fromMaybe "" . mconcat $ fmap prepend . showLine source <$> lines
where prepend "" = ""
prepend source = prefix : source
-- | Given a source, render a line to a string.
showLine :: Source Char -> Maybe (SplitDiff leaf Info) -> Maybe String
showLine :: HasField fields Range => Source Char -> Maybe (SplitDiff leaf (Record fields)) -> Maybe String
showLine source line | Just line <- line = Just . toString . (`slice` source) $ getRange line
| otherwise = Nothing
-- | Returns the header given two source blobs and a hunk.
header :: Both SourceBlob -> String
header blobs = intercalate "\n" [filepathHeader, fileModeHeader, beforeFilepath, afterFilepath] ++ "\n"
where filepathHeader = "diff --git a/" ++ pathA ++ " b/" ++ pathB
header blobs = intercalate "\n" [filepathHeader, fileModeHeader, beforeFilepath, afterFilepath] <> "\n"
where filepathHeader = "diff --git a/" <> pathA <> " b/" <> pathB
fileModeHeader = case (modeA, modeB) of
(Nothing, Just mode) -> intercalate "\n" [ "new file mode " ++ modeToDigits mode, blobOidHeader ]
(Just mode, Nothing) -> intercalate "\n" [ "deleted file mode " ++ modeToDigits mode, blobOidHeader ]
(Just mode, Just other) | mode == other -> "index " ++ oidA ++ ".." ++ oidB ++ " " ++ modeToDigits mode
(Nothing, Just mode) -> intercalate "\n" [ "new file mode " <> modeToDigits mode, blobOidHeader ]
(Just mode, Nothing) -> intercalate "\n" [ "deleted file mode " <> modeToDigits mode, blobOidHeader ]
(Just mode, Just other) | mode == other -> "index " <> oidA <> ".." <> oidB <> " " <> modeToDigits mode
(Just mode1, Just mode2) -> intercalate "\n" [
"old mode " ++ modeToDigits mode1,
"new mode " ++ modeToDigits mode2,
"old mode " <> modeToDigits mode1,
"new mode " <> modeToDigits mode2,
blobOidHeader
]
(Nothing, Nothing) -> ""
blobOidHeader = "index " ++ oidA ++ ".." ++ oidB
blobOidHeader = "index " <> oidA <> ".." <> oidB
modeHeader :: String -> Maybe SourceKind -> String -> String
modeHeader ty maybeMode path = case maybeMode of
Just _ -> ty ++ "/" ++ path
Just _ -> ty <> "/" <> path
Nothing -> "/dev/null"
beforeFilepath = "--- " ++ modeHeader "a" modeA pathA
afterFilepath = "+++ " ++ modeHeader "b" modeB pathB
beforeFilepath = "--- " <> modeHeader "a" modeA pathA
afterFilepath = "+++ " <> modeHeader "b" modeB pathB
(pathA, pathB) = runJoin $ path <$> blobs
(oidA, oidB) = runJoin $ oid <$> blobs
(modeA, modeB) = runJoin $ blobKind <$> blobs
-- | A hunk representing no changes.
emptyHunk :: Hunk (SplitDiff a Info)
emptyHunk :: Hunk (SplitDiff a annotation)
emptyHunk = Hunk { offset = mempty, changes = [], trailingContext = [] }
-- | Render a diff as a series of hunks.
hunks :: Show a => Diff a Info -> Both SourceBlob -> [Hunk (SplitDiff a Info)]
hunks :: HasField fields Range => Diff a (Record fields) -> Both SourceBlob -> [Hunk (SplitDiff a (Record fields))]
hunks _ blobs | sources <- source <$> blobs
, sourcesEqual <- runBothWith (==) sources
, sourcesNull <- runBothWith (&&) (null <$> sources)
@ -120,14 +121,14 @@ hunks diff blobs = hunksInRows (pure 1) $ alignDiff (source <$> blobs) diff
-- | Given beginning line numbers, turn rows in a split diff into hunks in a
-- | patch.
hunksInRows :: Both (Sum Int) -> [Join These (SplitDiff a Info)] -> [Hunk (SplitDiff a Info)]
hunksInRows :: Both (Sum Int) -> [Join These (SplitDiff a annotation)] -> [Hunk (SplitDiff a annotation)]
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 :: Both (Sum Int) -> [Join These (SplitDiff a Info)] -> Maybe (Hunk (SplitDiff a Info), [Join These (SplitDiff a Info)])
nextHunk :: Both (Sum Int) -> [Join These (SplitDiff a annotation)] -> Maybe (Hunk (SplitDiff a annotation), [Join These (SplitDiff a annotation)])
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')
@ -139,7 +140,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 :: Both (Sum Int) -> [Join These (SplitDiff a Info)] -> Maybe (Both (Sum Int), Change (SplitDiff a Info), [Join These (SplitDiff a Info)])
nextChange :: Both (Sum Int) -> [Join These (SplitDiff a annotation)] -> Maybe (Both (Sum Int), Change (SplitDiff a annotation), [Join These (SplitDiff a annotation)])
nextChange start rows = case changeIncludingContext leadingContext afterLeadingContext of
Nothing -> Nothing
Just (change, afterChanges) -> Just (start <> mconcat (rowIncrement <$> skippedContext), change, afterChanges)
@ -149,12 +150,12 @@ nextChange start rows = case changeIncludingContext leadingContext afterLeadingC
-- | 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 :: [Join These (SplitDiff a Info)] -> [Join These (SplitDiff a Info)] -> Maybe (Change (SplitDiff a Info), [Join These (SplitDiff a Info)])
changeIncludingContext :: [Join These (SplitDiff a annotation)] -> [Join These (SplitDiff a annotation)] -> Maybe (Change (SplitDiff a annotation), [Join These (SplitDiff a annotation)])
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 :: Join These (SplitDiff a Info) -> Bool
rowHasChanges :: Join These (SplitDiff a annotation) -> Bool
rowHasChanges row = or (hasChanges <$> row)

14
src/Renderer/Split.hs
View File

@ -7,6 +7,7 @@ import Data.Bifunctor.Join
import Data.Foldable
import Data.Functor.Both
import Data.Functor.Foldable (cata)
import Data.Record
import qualified Data.Text.Lazy as TL
import Data.These
import Info
@ -56,7 +57,7 @@ splitPatchToClassName patch = stringValue $ "patch " ++ case patch of
SplitReplace _ -> "replace"
-- | Render a diff as an HTML split diff.
split :: Renderer
split :: (HasField fields Category, HasField fields Range, HasField fields Size) => Renderer (Record fields)
split diff blobs = TL.toStrict . renderHtml
. docTypeHtml
. ((head $ link ! A.rel "stylesheet" ! A.href "style.css") <>)
@ -79,10 +80,8 @@ split diff blobs = TL.toStrict . renderHtml
columnWidth = max (20 + digits maxNumber * 8) 40
-- | Render a line with numbers as an HTML row.
numberedLinesToMarkup :: Join These (Int, SplitDiff a Info) -> Markup
numberedLinesToMarkup numberedLines = tr $ runBothWith (<>) (renderLine <$> Join (fromThese Nothing Nothing (runJoin (Just <$> numberedLines))) <*> sources) <> string "\n"
renderLine :: Maybe (Int, SplitDiff leaf Info) -> Source Char -> Markup
renderLine (Just (number, line)) source = toMarkup $ Renderable (hasChanges line, number, Renderable (source, line))
renderLine _ _ =
td mempty ! A.class_ (stringValue "blob-num blob-num-empty empty-cell")
@ -92,7 +91,7 @@ split diff blobs = TL.toStrict . renderHtml
-- | Something that can be rendered as markup.
newtype Renderable a = Renderable a
instance ToMarkup f => ToMarkup (Renderable (Source Char, Info, Syntax a (f, Range))) where
instance (ToMarkup f, HasField fields Category, HasField fields Range, HasField fields Size) => ToMarkup (Renderable (Source Char, Record fields, Syntax a (f, Range))) where
toMarkup (Renderable (source, info, syntax)) = (! A.data_ (stringValue (show (unSize (size info))))) . classifyMarkup (category info) $ case syntax of
Leaf _ -> span . string . toString $ slice (characterRange info) source
Indexed children -> ul . mconcat $ wrapIn li <$> contentElements source (characterRange info) children
@ -112,13 +111,12 @@ wrapIn _ l@Blaze.Content{} = l
wrapIn _ l@Blaze.Comment{} = l
wrapIn f p = f p
instance ToMarkup (Renderable (Source Char, Term a Info)) where
instance (HasField fields Category, HasField fields Range, HasField fields Size) => ToMarkup (Renderable (Source Char, Term a (Record fields))) where
toMarkup (Renderable (source, term)) = Prologue.fst $ cata (\ (info :< syntax) -> (toMarkup $ Renderable (source, info, syntax), characterRange info)) term
instance ToMarkup (Renderable (Source Char, SplitDiff a Info)) where
instance (HasField fields Category, HasField fields Range, HasField fields Size) => ToMarkup (Renderable (Source Char, SplitDiff a (Record fields))) where
toMarkup (Renderable (source, diff)) = Prologue.fst $ iter (\ (info :< syntax) -> (toMarkup $ Renderable (source, info, syntax), characterRange info)) $ toMarkupAndRange <$> diff
where toMarkupAndRange :: SplitPatch (Term a Info) -> (Markup, Range)
toMarkupAndRange patch = let term@(info :< _) = runCofree $ getSplitTerm patch in
where toMarkupAndRange patch = let term@(info :< _) = runCofree $ getSplitTerm patch in
((div ! A.class_ (splitPatchToClassName patch) ! A.data_ (stringValue (show (unSize (size info))))) . toMarkup $ Renderable (source, cofree term), characterRange info)
instance ToMarkup a => ToMarkup (Renderable (Bool, Int, a)) where

7
src/Renderer/Summary.hs
View File

@ -1,11 +1,14 @@
module Renderer.Summary where
import Category
import Prologue
import Renderer
import DiffSummary
import Data.Aeson
import Data.ByteString.Builder
import Data.Record
import Data.Text (pack)
import DiffSummary
import Range
summary :: Renderer
summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields)
summary diff _ = toS . toLazyByteString . fromEncoding . foldable $ pack . show <$> diffSummary diff

5
src/TreeSitter.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
module TreeSitter where
import Prologue hiding (Constructor)
@ -15,7 +16,7 @@ import Text.Parser.TreeSitter hiding (Language(..))
import qualified Text.Parser.TreeSitter as TS
-- | Returns a TreeSitter parser for the given language and TreeSitter grammar.
treeSitterParser :: Language -> Ptr TS.Language -> Parser
treeSitterParser :: Language -> Ptr TS.Language -> Parser '[Range, Category, Size, Cost]
treeSitterParser language grammar contents = do
document <- ts_document_make
ts_document_set_language document grammar
@ -49,7 +50,7 @@ defaultCategoryForNodeName name = case name of
_ -> Other name
-- | Return a parser for a tree sitter language & document.
documentToTerm :: Language -> Ptr Document -> Parser
documentToTerm :: Language -> Ptr Document -> Parser '[Range, Category, Size, Cost]
documentToTerm language document contents = alloca $ \ root -> do
ts_document_root_node_p document root
toTerm root

23
test/AlignmentSpec.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
module AlignmentSpec where
import Alignment
@ -14,7 +15,6 @@ import Data.Record
import Data.String
import Data.Text.Arbitrary ()
import Data.These
import Info
import Patch
import Prologue hiding (fst, snd)
import qualified Prologue
@ -22,7 +22,6 @@ import Range
import qualified Source
import SplitDiff
import Syntax
import Category
import Term
import Test.Hspec
import Test.Hspec.QuickCheck
@ -32,7 +31,7 @@ spec :: Spec
spec = parallel $ do
describe "alignBranch" $ do
it "produces symmetrical context" $
alignBranch getRange ([] :: [Join These (SplitDiff String Info)]) (both [Range 0 2, Range 2 4] [Range 0 2, Range 2 4]) `shouldBe`
alignBranch getRange ([] :: [Join These (SplitDiff String (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 2, Range 2 4]) `shouldBe`
[ Join (These (Range 0 2, [])
(Range 0 2, []))
, Join (These (Range 2 4, [])
@ -40,7 +39,7 @@ spec = parallel $ do
]
it "produces asymmetrical context" $
alignBranch getRange ([] :: [Join These (SplitDiff String Info)]) (both [Range 0 2, Range 2 4] [Range 0 1]) `shouldBe`
alignBranch getRange ([] :: [Join These (SplitDiff String (Record '[Range]))]) (both [Range 0 2, Range 2 4] [Range 0 1]) `shouldBe`
[ Join (These (Range 0 2, [])
(Range 0 1, []))
, Join (This (Range 2 4, []))
@ -254,13 +253,13 @@ instance Arbitrary BranchElement where
counts :: [Join These (Int, a)] -> Both Int
counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap Prologue.fst <$> numbered))
align :: Both (Source.Source Char) -> ConstructibleFree (Patch (Term String Info)) (Both Info) -> PrettyDiff (SplitDiff String Info)
align :: Both (Source.Source Char) -> ConstructibleFree (Patch (Term String (Record '[Range]))) (Both (Record '[Range])) -> PrettyDiff (SplitDiff String (Record '[Range]))
align sources = PrettyDiff sources . fmap (fmap (getRange &&& identity)) . alignDiff sources . deconstruct
info :: Int -> Int -> Info
info start end = Range start end .: StringLiteral .: 0 .: 0 .: RNil
info :: Int -> Int -> Record '[Range]
info start end = Range start end .: RNil
prettyDiff :: Both (Source.Source Char) -> [Join These (ConstructibleFree (SplitPatch (Term String Info)) Info)] -> PrettyDiff (SplitDiff String Info)
prettyDiff :: Both (Source.Source Char) -> [Join These (ConstructibleFree (SplitPatch (Term String (Record '[Range]))) (Record '[Range]))] -> PrettyDiff (SplitDiff String (Record '[Range]))
prettyDiff sources = PrettyDiff sources . fmap (fmap ((getRange &&& identity) . deconstruct))
data PrettyDiff a = PrettyDiff { unPrettySources :: Both (Source.Source Char), unPrettyLines :: [Join These (Range, a)] }
@ -279,14 +278,14 @@ newtype ConstructibleFree patch annotation = ConstructibleFree { deconstruct ::
class PatchConstructible p where
insert :: Term String Info -> p
delete :: Term String Info -> p
insert :: Term String (Record '[Range]) -> p
delete :: Term String (Record '[Range]) -> p
instance PatchConstructible (Patch (Term String Info)) where
instance PatchConstructible (Patch (Term String (Record '[Range]))) where
insert = Insert
delete = Delete
instance PatchConstructible (SplitPatch (Term String Info)) where
instance PatchConstructible (SplitPatch (Term String (Record '[Range]))) where
insert = SplitInsert
delete = SplitDelete

11
test/CorpusSpec.hs
View File

@ -1,21 +1,24 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DataKinds, FlexibleContexts, GeneralizedNewtypeDeriving #-}
module CorpusSpec where
import System.IO
import Data.String
import Diffing
import Renderer
import qualified Renderer.JSON as J
import qualified Renderer.Patch as P
import qualified Renderer.Split as Split
import Category
import Control.DeepSeq
import Data.Functor.Both
import Data.List as List
import Data.Map as Map
import Data.Record
import Data.Set as Set
import qualified Data.Text as T
import Info
import Prologue hiding (fst, snd)
import Range
import qualified Source as S
import System.FilePath
import System.FilePath.Glob
@ -39,10 +42,8 @@ spec = parallel $ do
let tests = correctTests =<< paths
traverse_ (\ (formatName, renderer, paths, output) -> it (normalizeName (fst paths) ++ " (" ++ formatName ++ ")") $ testDiff renderer paths output matcher) tests
correctTests :: (Both FilePath, Maybe FilePath, Maybe FilePath, Maybe FilePath) -> [(String, Renderer, 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, Both FilePath, Maybe FilePath)]
testsForPaths (paths, json, patch, split) = [ ("json", J.json, paths, json), ("patch", P.patch, paths, patch), ("split", Split.split, paths, split) ]
-- | Return all the examples from the given directory. Examples are expected to
@ -69,7 +70,7 @@ 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 -> Both FilePath -> Maybe FilePath -> (Verbatim -> Verbatim -> Expectation) -> Expectation
testDiff :: Renderer (Record '[Range, Category, Size, Cost]) -> Both FilePath -> Maybe FilePath -> (Verbatim -> Verbatim -> Expectation) -> Expectation
testDiff renderer paths diff matcher = do
sources <- sequence $ readAndTranscodeFile <$> paths
actual <- Verbatim <$> diffFiles parser renderer (sourceBlobs sources)

13
test/DiffSummarySpec.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
module DiffSummarySpec where
import Prologue
@ -5,20 +6,18 @@ import Data.Record
import Data.String
import Test.Hspec
import Diff
import Info
import Syntax
import Patch
import Range
import Category
import DiffSummary
arrayInfo :: Info
arrayInfo = rangeAt 0 .: ArrayLiteral .: 2 .: 0 .: RNil
arrayInfo :: Record '[Category]
arrayInfo = ArrayLiteral .: RNil
literalInfo :: Info
literalInfo = rangeAt 1 .: StringLiteral .: 1 .: 0 .: RNil
literalInfo :: Record '[Category]
literalInfo = StringLiteral .: RNil
testDiff :: Diff String Info
testDiff :: Diff String (Record '[Category])
testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "a")) ])
testSummary :: DiffSummary DiffInfo