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

Merge branch 'master' into cofree-and-bifunctors-sitting-in-a-tree-a-l-i-g-n-edly

Browse Source 
# Conflicts:
#	semantic-diff.cabal
#	src/Alignment.hs
#	src/Control/Comonad/Cofree.hs
#	src/Data/Adjoined.hs
#	src/Diffing.hs
#	src/Interpreter.hs
#	src/Prologue.hs
#	src/Renderer/JSON.hs
#	src/Renderer/Patch.hs
#	src/Renderer/Split.hs
#	src/SplitDiff.hs
#	src/Term.hs
#	test/AlignmentSpec.hs
#	test/ArbitraryTerm.hs
#	test/PatchOutputSpec.hs
This commit is contained in:
Rob Rix 2016-05-27 09:35:26 -04:00
commit de6d7edec2
33 changed files with 308 additions and 223 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
HLint.hs
View File

@ -8,3 +8,6 @@ error "generalize forM_" = forM_ ==> for_
error "Avoid return" =
return ==> pure
where note = "return is obsolete as of GHC 7.10"
error "use pure" = free . Pure ==> pure
error "use extract" = headF . runCofree ==> extract

11
semantic-diff.cabal
View File

@ -16,8 +16,6 @@ library
exposed-modules: Algorithm
, Alignment
, Category
, Control.Comonad.Cofree
, Control.Monad.Free
, Data.Functor.Both
, Data.OrderedMap
, Diff
@ -34,12 +32,14 @@ library
, Renderer.JSON
, Renderer.Patch
, Renderer.Split
, Renderer.Summary
, SES
, Source
, SplitDiff
, Syntax
, Term
, TreeSitter
, DiffSummary
, Prologue
build-depends: aeson
, base >= 4.8 && < 5
@ -58,8 +58,10 @@ library
, these
, tree-sitter-parsers
, vector
, protolude
, recursion-schemes
, free
, comonad
, protolude
default-language: Haskell2010
default-extensions: DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, OverloadedStrings, NoImplicitPrelude
ghc-options: -Wall -fno-warn-name-shadowing -O2 -threaded -fprof-auto "-with-rtsopts=-N -p -s -h -i0.1" -j
@ -75,6 +77,7 @@ test-suite semantic-diff-test
, OrderedMapSpec
, PatchOutputSpec
, TermSpec
, DiffSummarySpec
build-depends: base
, bifunctors
, bytestring
@ -89,6 +92,8 @@ test-suite semantic-diff-test
, semantic-diff
, text >= 1.2.1.3
, these
, free
, recursion-schemes >= 4.1
if os(darwin)
ghc-options: -threaded -rtsopts -with-rtsopts=-N -j
else

2
src/Algorithm.hs
View File

@ -1,6 +1,6 @@
module Algorithm where
import Control.Monad.Free
import Control.Monad.Trans.Free
import Operation
-- | A lazily-produced AST for diffing.

25
src/Alignment.hs
View File

@ -11,10 +11,8 @@ module Alignment
) where
import Control.Applicative
import Control.Arrow ((&&&), (***))
import Control.Comonad.Cofree
import Control.Arrow ((***))
import Control.Monad
import Control.Monad.Free
import Data.Align
import Data.Biapplicative
import Data.Bifunctor.Join
@ -22,6 +20,7 @@ import Data.Copointed
import Data.Foldable
import Data.Function
import Data.Functor.Both as Both
import Data.Functor.Foldable hiding (Foldable, fold)
import Data.Functor.Identity
import Data.List (partition)
import Data.Maybe
@ -51,28 +50,28 @@ hasChanges = or . (True <$)
type AlignedDiff leaf = [Join These (SplitDiff leaf Info)]
alignDiff :: Both (Source Char) -> Diff leaf Info -> AlignedDiff leaf
alignDiff sources diff = iter (uncurry (alignSyntax (runBothWith ((Join .) . These)) ((Free .) . Annotated) getRange sources) . (annotation &&& syntax)) (alignPatch sources <$> diff)
alignDiff sources diff = iter (alignSyntax (runBothWith ((Join .) . These)) (free . Free) getRange sources) (alignPatch sources <$> diff)
alignPatch :: Both (Source Char) -> Patch (Term leaf Info) -> AlignedDiff leaf
alignPatch sources patch = case patch of
Delete term -> fmap (Pure . SplitDelete) <$> hylo (alignSyntax this (:<) getRange (Identity (fst sources))) unCofree (Identity <$> term)
Insert term -> fmap (Pure . SplitInsert) <$> hylo (alignSyntax that (:<) getRange (Identity (snd sources))) unCofree (Identity <$> term)
Replace term1 term2 -> fmap (Pure . SplitReplace) <$> alignWith (fmap (these identity identity const . runJoin) . Join)
(hylo (alignSyntax this (:<) getRange (Identity (fst sources))) unCofree (Identity <$> term1))
(hylo (alignSyntax that (:<) getRange (Identity (snd sources))) unCofree (Identity <$> term2))
where getRange = characterRange . copoint
Delete term -> fmap (pure . SplitDelete) <$> hylo (alignSyntax this cofree getRange (Identity (fst sources))) runCofree (Identity <$> term)
Insert term -> fmap (pure . SplitInsert) <$> hylo (alignSyntax that cofree getRange (Identity (snd sources))) runCofree (Identity <$> term)
Replace term1 term2 -> fmap (pure . SplitReplace) <$> alignWith (fmap (these identity identity const . runJoin) . Join)
(hylo (alignSyntax this cofree getRange (Identity (fst sources))) runCofree (Identity <$> term1))
(hylo (alignSyntax that cofree getRange (Identity (snd sources))) runCofree (Identity <$> term2))
where getRange = characterRange . extract
this = Join . This . runIdentity
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 => (forall a. f a -> Join These a) -> (Info -> Syntax leaf term -> term) -> (term -> Range) -> f (Source Char) -> f Info -> Syntax leaf [Join These term] -> [Join These term]
alignSyntax toJoinThese toNode getRange sources infos syntax = case syntax of
alignSyntax :: Applicative f => (forall a. f a -> Join These a) -> (CofreeF (Syntax leaf) Info term -> term) -> (term -> Range) -> f (Source Char) -> CofreeF (Syntax leaf) (f Info) [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 . fmap runIdentity) <$> alignBranch getRange (Identity <$> children) (modifyJoin (fromThese [] []) lineRanges)
Fixed children -> catMaybes $ wrapInBranch (Fixed . fmap runIdentity) <$> alignBranch getRange (Identity <$> children) (modifyJoin (fromThese [] []) lineRanges)
Keyed children -> catMaybes $ wrapInBranch (Keyed . Map.fromList) <$> alignBranch getRange (Map.toList children) (modifyJoin (fromThese [] []) lineRanges)
where lineRanges = toJoinThese $ actualLineRanges <$> (characterRange <$> infos) <*> sources
wrapInBranch constructor = applyThese $ toJoinThese ((\ info (range, children) -> toNode (info { characterRange = range }) (constructor children)) <$> infos)
wrapInBranch constructor = applyThese $ toJoinThese ((\ info (range, children) -> toNode (info { characterRange = range } :< constructor children)) <$> infos)
{-

3
src/Category.hs
View File

@ -3,7 +3,6 @@ module Category where
import Prologue
import Data.String
import Control.Comonad.Cofree
import Data.Set
import Term
@ -35,7 +34,7 @@ class Categorizable a where
categories :: a -> Set Category
instance Categorizable annotation => Categorizable (Term a annotation) where
categories (annotation :< _) = categories annotation
categories term | (annotation :< _) <- runCofree term = categories annotation
-- | Test whether the categories from the categorizables intersect.
comparable :: Categorizable a => a -> a -> Bool

27
src/Control/Comonad/Cofree.hs
View File

@ -1,27 +0,0 @@
{-# LANGUAGE UndecidableInstances #-}
module Control.Comonad.Cofree where
import Control.Arrow
import Data.Copointed
import Prologue
data Cofree functor annotation = annotation :< (functor (Cofree functor annotation))
deriving (Functor, Foldable, Traversable)
instance (Eq annotation, Eq (functor (Cofree functor annotation))) => Eq (Cofree functor annotation) where
(a :< f) == (b :< g) = a == b && f == g
instance (Show annotation, Show (functor (Cofree functor annotation))) => Show (Cofree functor annotation) where
showsPrec n (a :< f) = showsPrec n a . (" :< " ++) . showsPrec n f
unwrap :: Cofree functor annotation -> functor (Cofree functor annotation)
unwrap (_ :< f) = f
unfold :: Functor functor => (seed -> (annotation, functor seed)) -> seed -> Cofree functor annotation
unfold grow seed = case grow seed of (annotation, functor) -> annotation :< (unfold grow <$> functor)
unCofree :: Cofree f a -> (a, f (Cofree f a))
unCofree = copoint &&& unwrap
instance Copointed (Cofree functor) where
copoint (annotation :< _) = annotation

20
src/Control/Monad/Free.hs
View File

@ -1,20 +0,0 @@
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Free where
import Prologue
data Free functor pure = Free (functor (Free functor pure)) | Pure pure
deriving (Functor, Foldable, Traversable)
instance (Eq pure, Eq (functor (Free functor pure))) => Eq (Free functor pure) where
Pure a == Pure b = a == b
Free f == Free g = f == g
_ == _ = False
instance (Show pure, Show (functor (Free functor pure))) => Show (Free functor pure) where
showsPrec n (Pure a) = ("Pure " ++) . showsPrec n a
showsPrec n (Free f) = ("Free " ++) . showsPrec n f
iter :: Functor functor => (functor pure -> pure) -> Free functor pure -> pure
iter _ (Pure a) = a
iter f (Free g) = f (iter f <$> g)

14
src/Diff.hs
View File

@ -1,20 +1,20 @@
{-# LANGUAGE TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
module Diff where
import Prologue
import Control.Monad.Free
import Data.Functor.Foldable as Foldable
import Data.Functor.Both
import Patch
import Syntax
import Term
-- | An annotated syntax in a diff tree.
data Annotated a annotation f = Annotated { annotation :: !annotation, syntax :: !(Syntax a f) }
deriving (Functor, Eq, Show, Foldable)
-- | An annotated series of patches of terms.
type Diff a annotation = Free (Annotated a (Both annotation)) (Patch (Term a annotation))
type Diff a annotation = Free (CofreeF (Syntax a) (Both annotation)) (Patch (Term a annotation))
type instance Base (Free f a) = FreeF f a
instance (Functor f) => Foldable.Foldable (Free f a) where project = runFree
instance (Functor f) => Foldable.Unfoldable (Free f a) where embed = free
-- | Sum the result of a transform applied to all the patches in the diff.
diffSum :: (Patch (Term a annotation) -> Integer) -> Diff a annotation -> Integer
diffSum patchCost diff = sum $ fmap patchCost diff

4
src/DiffOutput.hs
View File

@ -7,6 +7,7 @@ import Diffing
import Parser
import qualified Renderer.JSON as J
import qualified Renderer.Patch as P
import qualified Renderer.Summary as S
import Renderer
import Renderer.Split
import Source
@ -20,6 +21,7 @@ textDiff parser arguments sources = case format arguments of
Split -> diffFiles parser split sources
Patch -> diffFiles parser P.patch sources
JSON -> diffFiles parser J.json sources
Summary -> diffFiles parser S.summary sources
-- | Returns a truncated diff given diff arguments and two source blobs.
truncatedDiff :: DiffArguments -> Both SourceBlob -> IO Text
@ -27,6 +29,7 @@ truncatedDiff arguments sources = case format arguments of
Split -> pure ""
Patch -> pure $ P.truncatePatch arguments sources
JSON -> pure "{}"
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 ()
@ -42,3 +45,4 @@ printDiff parser arguments sources = case format arguments of
IO.withFile outputPath IO.WriteMode (`TextIO.hPutStr` rendered)
Patch -> TextIO.putStr =<< diffFiles parser P.patch sources
JSON -> TextIO.putStr =<< diffFiles parser J.json sources
Summary -> TextIO.putStr =<< diffFiles parser S.summary sources

84
src/DiffSummary.hs Normal file
View File

@ -0,0 +1,84 @@
{-# LANGUAGE DataKinds, TypeFamilies, ScopedTypeVariables, FlexibleInstances, RecordWildCards #-}
module DiffSummary (DiffSummary(..), diffSummary, DiffInfo(..)) where
import Prologue hiding (fst, snd)
import Data.String
import Data.Maybe (fromJust)
import Diff
import Info
import Patch
import Term
import Syntax
import Category
import Data.Functor.Foldable as Foldable
import Data.Functor.Both
import Data.OrderedMap
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 term = case runCofree term of
(_ :< Leaf leaf) -> Just (toCategoryName leaf)
(_ :< Keyed children) -> Just (unpack . mconcat $ keys children)
(_ :< Indexed children) -> toCategoryName . toCategory <$> head (extract <$> children)
(_ :< Fixed children) -> toCategoryName . toCategory <$> head (extract <$> children)
class HasCategory a where
toCategoryName :: a -> String
instance HasCategory String where
toCategoryName = identity
instance HasCategory Text where
toCategoryName = unpack
instance HasCategory Category where
toCategoryName category = case category of
BinaryOperator -> "binary operator"
DictionaryLiteral -> "dictionary"
Pair -> "pair"
FunctionCall -> "function call"
StringLiteral -> "string"
IntegerLiteral -> "integer"
SymbolLiteral -> "symbol"
ArrayLiteral -> "array"
(Other s) -> s
instance HasCategory leaf => HasCategory (Term leaf Info) where
toCategoryName = toCategoryName . toCategory . extract
data DiffSummary a = DiffSummary {
patch :: Patch DiffInfo,
parentAnnotations :: [DiffInfo]
} deriving (Eq, Functor)
instance Show a => Show (DiffSummary a) where
showsPrec _ DiffSummary{..} s = (++s) $ case patch of
(Insert termInfo) -> "Added the " ++ "'" ++ fromJust (termName termInfo) ++ "' " ++ categoryName termInfo
++ maybeParentContext parentAnnotations
(Delete termInfo) -> "Deleted the " ++ "'" ++ fromJust (termName termInfo) ++ "' " ++ categoryName termInfo
++ maybeParentContext parentAnnotations
(Replace t1 t2) -> "Replaced the " ++ "'" ++ fromJust (termName t1) ++ "' " ++ categoryName t1
++ " with the " ++ "'" ++ fromJust (termName t2) ++ "' " ++ categoryName t2
++ maybeParentContext parentAnnotations
where maybeParentContext parentAnnotations = if null parentAnnotations
then ""
else " in the " ++ intercalate "/" (categoryName <$> parentAnnotations) ++ " context"
diffSummary :: HasCategory leaf => Diff leaf Info -> [DiffSummary DiffInfo]
diffSummary = cata diffSummary' where
diffSummary' :: HasCategory leaf => Base (Diff leaf Info) [DiffSummary DiffInfo] -> [DiffSummary DiffInfo]
diffSummary' (Free (_ :< Leaf _)) = [] -- Skip leaves since they don't have any changes
diffSummary' (Free (infos :< Indexed children)) = prependSummary (DiffInfo (toCategoryName . toCategory $ snd infos) Nothing) <$> join children
diffSummary' (Free (infos :< Fixed children)) = prependSummary (DiffInfo (toCategoryName . toCategory $ snd infos) Nothing) <$> join children
diffSummary' (Free (infos :< Keyed children)) = prependSummary (DiffInfo (toCategoryName . toCategory $ snd infos) Nothing) <$> join (Prologue.toList children)
diffSummary' (Pure (Insert term)) = [DiffSummary (Insert (DiffInfo (toCategoryName term) (maybeTermName term))) []]
diffSummary' (Pure (Delete term)) = [DiffSummary (Delete (DiffInfo (toCategoryName term) (maybeTermName term))) []]
diffSummary' (Pure (Replace t1 t2)) = [DiffSummary (Replace (DiffInfo (toCategoryName t1) (maybeTermName t1)) (DiffInfo (toCategoryName t2) (maybeTermName t2))) []]
prependSummary :: DiffInfo -> DiffSummary DiffInfo -> DiffSummary DiffInfo
prependSummary annotation summary = summary { parentAnnotations = annotation : parentAnnotations summary }
toCategory :: Info -> Category
toCategory info = fromMaybe (Other "Unknown") (maybeFirstCategory info)

43
src/Diffing.hs
View File

@ -1,6 +1,13 @@
module Diffing where
import Prologue
import Data.Bifunctor.Join
import qualified Data.ByteString.Char8 as B1
import Data.Functor.Both
import Data.Functor.Foldable
import qualified Data.Text as T
import qualified Data.Text.ICU.Detect as Detect
import qualified Data.Text.ICU.Convert as Convert
import Diff
import Info
import Interpreter
@ -10,21 +17,11 @@ import Range
import Renderer
import Source hiding ((++))
import Syntax
import System.FilePath
import Term
import TreeSitter
import Text.Parser.TreeSitter.Language
import Control.Monad.Free
import Control.Comonad.Cofree
import Data.Bifunctor.Join
import Data.Copointed
import Data.Functor.Both
import qualified Data.ByteString.Char8 as B1
import qualified Data.Text as T
import qualified Data.Text.ICU.Detect as Detect
import qualified Data.Text.ICU.Convert as Convert
import System.FilePath
-- | Return a parser based on the file extension (including the ".").
parserForType :: T.Text -> Parser
parserForType mediaType = case languageForType mediaType of
@ -35,8 +32,8 @@ parserForType mediaType = case languageForType mediaType of
-- | A fallback parser that treats a file simply as rows of strings.
lineByLineParser :: Parser
lineByLineParser input = pure . root $ case foldl' annotateLeaves ([], 0) lines of
(leaves, _) -> leaves
lineByLineParser input = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of
(leaves, _) -> cofree <$> leaves
where
lines = actualLines input
root children = Info (Range 0 $ length input) mempty (1 + fromIntegral (length children)) :< Indexed children
@ -54,14 +51,15 @@ parserForFilepath = parserForType . T.pack . takeExtension
breakDownLeavesByWord :: Source Char -> Term T.Text Info -> Term T.Text Info
breakDownLeavesByWord source = cata replaceIn
where
replaceIn (Info range categories _) (Leaf _)
replaceIn :: TermF T.Text Info (Term T.Text Info) -> Term T.Text Info
replaceIn (Info range categories _ :< Leaf _)
| ranges <- rangesAndWordsInSource range
, length ranges > 1
= Info range categories (1 + fromIntegral (length ranges)) :< Indexed (makeLeaf categories <$> ranges)
replaceIn info syntax
= info { size = 1 + sum (size . copoint <$> syntax) } :< syntax
= cofree $ Info range categories (1 + fromIntegral (length ranges)) :< Indexed (makeLeaf categories <$> ranges)
replaceIn (info :< syntax)
= cofree $ info { size = 1 + sum (size . extract <$> syntax) } :< syntax
rangesAndWordsInSource range = rangesAndWordsFrom (start range) (toString $ slice range source)
makeLeaf categories (range, substring) = Info range categories 1 :< Leaf (T.pack substring)
makeLeaf categories (range, substring) = cofree $ Info range categories 1 :< Leaf (T.pack substring)
-- | Transcode a file to a unicode source.
transcode :: B1.ByteString -> IO (Source Char)
@ -80,7 +78,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 T.Text -> Both SourceBlob -> IO T.Text
diffFiles :: Parser -> Renderer -> Both SourceBlob -> IO T.Text
diffFiles parser renderer sourceBlobs = do
let sources = source <$> sourceBlobs
terms <- sequence $ parser <$> sources
@ -89,9 +87,10 @@ diffFiles parser renderer sourceBlobs = do
-- | The sum of the node count of the diff’s patches.
diffCostWithCachedTermSizes :: Diff a Info -> Integer
diffCostWithCachedTermSizes = diffSum (getSum . foldMap (Sum . size . copoint))
diffCostWithCachedTermSizes = diffSum (getSum . foldMap (Sum . size . extract))
-- | The absolute difference between the node counts of a diff.
diffCostWithAbsoluteDifferenceOfCachedDiffSizes :: Diff a Info -> Integer
diffCostWithAbsoluteDifferenceOfCachedDiffSizes (Free (Annotated (Join (before, after)) _)) = abs $ size before - size after
diffCostWithAbsoluteDifferenceOfCachedDiffSizes (Pure patch) = sum $ size . copoint <$> patch
diffCostWithAbsoluteDifferenceOfCachedDiffSizes term = case runFree term of
Free (Join (before, after) :< _) -> abs $ size before - size after
Pure patch -> sum $ size . extract <$> patch

3
src/Info.hs
View File

@ -11,3 +11,6 @@ data Info = Info { characterRange :: !Range, categories :: !(Set Category), size
instance Categorizable Info where
categories = Info.categories
maybeFirstCategory :: (Categorizable a) => a -> Maybe Category
maybeFirstCategory term = listToMaybe . toList $ Category.categories term

59
src/Interpreter.hs
View File

@ -2,15 +2,11 @@ module Interpreter (interpret, Comparable, diffTerms) where
import Algorithm
import Category
import Control.Arrow
import Control.Comonad.Cofree
import Control.Monad.Free
import Data.Copointed
import Data.Functor.Foldable
import Data.Functor.Both
import qualified Data.OrderedMap as Map
import qualified Data.List as List
import Data.List ((\\))
import Data.Maybe
import Data.OrderedMap ((!))
import Diff
import Operation
@ -29,46 +25,47 @@ diffTerms cost = interpret comparable cost
-- | Diff two terms, given a function that determines whether two terms can be compared.
interpret :: (Eq a, Eq annotation) => Comparable a annotation -> Cost a annotation -> Term a annotation -> Term a annotation -> Diff a annotation
interpret comparable cost a b = fromMaybe (Pure $ Replace a b) $ constructAndRun comparable cost a b
interpret comparable cost a b = fromMaybe (pure $ Replace a b) $ constructAndRun comparable cost a b
-- | Constructs an algorithm and runs it
constructAndRun :: (Eq a, Eq annotation) => Comparable a annotation -> Cost a annotation -> Term a annotation -> Term a annotation -> Maybe (Diff a annotation)
constructAndRun _ _ a b | a == b = hylo (curry $ Free . uncurry Annotated) (copoint &&& unwrap) <$> zipTerms a b where
constructAndRun _ _ a b | a == b = hylo (\termF -> free . Free $ headF termF :< tailF termF) runCofree <$> zipTerms a b
constructAndRun comparable _ a b | not $ comparable a b = Nothing
constructAndRun comparable cost (annotation1 :< a) (annotation2 :< b) =
constructAndRun comparable cost t1 t2 =
run comparable cost $ algorithm a b where
algorithm (Indexed a') (Indexed b') = Free $ ByIndex a' b' (annotate . Indexed)
algorithm (Keyed a') (Keyed b') = Free $ ByKey a' b' (annotate . Keyed)
algorithm (Indexed a') (Indexed b') = free . Free $ ByIndex a' b' (annotate . Indexed)
algorithm (Keyed a') (Keyed b') = free . 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 (both annotation1 annotation2)
algorithm a' b' = free . Free $ Recursive (cofree (annotation1 :< a')) (cofree (annotation2 :< b')) pure
(annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2)
annotate = pure . free . Free . (:<) (both annotation1 annotation2)
-- | Runs the diff algorithm
run :: (Eq a, Eq annotation) => Comparable a annotation -> Cost a annotation -> Algorithm a annotation (Diff a annotation) -> Maybe (Diff a annotation)
run _ _ (Pure diff) = Just diff
run comparable cost algorithm = case runFree algorithm of
Pure diff -> Just diff
Free (Recursive t1 t2 f) -> run comparable cost . f $ recur a b where
(annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2)
annotate = free . Free . (both annotation1 annotation2 :<)
run comparable cost (Free (Recursive (annotation1 :< a) (annotation2 :< b) f)) = run comparable cost . f $ recur a b where
recur (Indexed a') (Indexed b') | length a' == length b' = annotate . Indexed $ zipWith (interpret comparable cost) a' b'
recur (Fixed a') (Fixed b') | length a' == length b' = annotate . Fixed $ zipWith (interpret comparable cost) a' b'
recur (Keyed a') (Keyed b') | Map.keys a' == bKeys = annotate . Keyed . Map.fromList . fmap repack $ bKeys
where
recur (Indexed a') (Indexed b') | length a' == length b' = annotate . Indexed $ zipWith (interpret comparable cost) a' b'
recur (Fixed a') (Fixed b') | length a' == length b' = annotate . Fixed $ zipWith (interpret comparable cost) a' b'
recur (Keyed a') (Keyed b') | Map.keys a' == bKeys = annotate . Keyed . Map.fromList . fmap repack $ bKeys where
bKeys = Map.keys b'
repack key = (key, interpretInBoth key a' b')
interpretInBoth key x y = interpret comparable cost (x ! key) (y ! key)
recur _ _ = Pure $ Replace (annotation1 :< a) (annotation2 :< b)
recur _ _ = pure $ Replace (cofree (annotation1 :< a)) (cofree (annotation2 :< b))
annotate = Free . Annotated (both annotation1 annotation2)
Free (ByKey a b f) -> run comparable cost $ f byKey where
byKey = Map.fromList $ toKeyValue <$> List.union aKeys bKeys
toKeyValue key | key `List.elem` deleted = (key, pure . Delete $ a ! key)
toKeyValue key | key `List.elem` inserted = (key, pure . Insert $ b ! key)
toKeyValue key = (key, interpret comparable cost (a ! key) (b ! key))
aKeys = Map.keys a
bKeys = Map.keys b
deleted = aKeys \\ bKeys
inserted = bKeys \\ aKeys
run comparable cost (Free (ByKey a b f)) = run comparable cost $ f byKey where
byKey = Map.fromList $ toKeyValue <$> List.union aKeys bKeys
toKeyValue key | List.elem key deleted = (key, Pure . Delete $ a ! key)
toKeyValue key | List.elem key inserted = (key, Pure . Insert $ b ! key)
toKeyValue key = (key, interpret comparable cost (a ! key) (b ! key))
aKeys = Map.keys a
bKeys = Map.keys b
deleted = aKeys \\ bKeys
inserted = bKeys \\ aKeys
run comparable cost (Free (ByIndex a b f)) = run comparable cost . f $ ses (constructAndRun comparable cost) cost a b
Free (ByIndex a b f) -> run comparable cost . f $ ses (constructAndRun comparable cost) cost a b

1
src/Language.hs
View File

@ -20,6 +20,7 @@ data Language =
| R
| Ruby
| Swift
deriving (Show)
-- | Returns a Language based on the file extension (including the ".").
languageForType :: Text -> Maybe Language

9
src/Parser.hs
View File

@ -8,8 +8,6 @@ import Info
import Range
import Syntax
import Term
import Control.Comonad.Cofree
import Data.Copointed
import qualified Data.OrderedMap as Map
import qualified Data.Set as Set
import Source
@ -42,13 +40,14 @@ isFixed = not . Set.null . Set.intersection fixedCategories
-- | Given a function that maps production names to sets of categories, produce
-- | a Constructor.
termConstructor :: (String -> Set.Set Category) -> Constructor
termConstructor mapping source range name children = Info range categories (1 + sum (size . copoint <$> children)) :< construct children
termConstructor mapping source range name children = cofree (Info range categories (1 + sum (size . extract <$> children)) :< construct children)
where
categories = mapping name
construct :: [Term Text Info] -> Syntax Text (Term Text Info)
construct [] = Leaf . pack . toString $ slice range source
construct children | isFixed categories = Fixed children
construct children | isKeyed categories = Keyed . Map.fromList $ assignKey <$> children
construct children = Indexed children
assignKey node@(Info _ categories _ :< Fixed (key : _)) | Set.member Pair categories = (getSubstring key, node)
assignKey node | Info _ categories _ :< Fixed (key : _) <- runCofree node, Set.member Pair categories = (getSubstring key, node)
assignKey node = (getSubstring node, node)
getSubstring (Info range _ _ :< _) = pack . toString $ slice range source
getSubstring term | Info range _ _ :< _ <- runCofree term = pack . toString $ slice range source

10
src/Patch.hs
View File

@ -1,4 +1,12 @@
module Patch where
module Patch
( Patch(..)
, after
, before
, unPatch
, patchSum
, maybeFst
, maybeSnd
) where
import Data.These
import Prologue

4
src/Prologue.hs
View File

@ -9,6 +9,10 @@ import Protolude as X
import Data.List (lookup)
import System.IO (FilePath)
import Control.Comonad.Trans.Cofree as X
import Control.Monad.Trans.Free as X
import Control.Comonad as X
import qualified GHC.Show as P
import qualified Debug.Trace as T

4
src/Renderer.hs
View File

@ -7,11 +7,11 @@ import Info
import Source
-- | A function that will render a diff, given the two source files.
type Renderer a = Diff a Info -> Both SourceBlob -> Text
type Renderer = Diff Text Info -> Both SourceBlob -> Text
data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath, outputPath :: FilePath }
deriving (Show)
-- | The available types of diff rendering.
data Format = Split | Patch | JSON
data Format = Split | Patch | JSON | Summary
deriving (Show)

23
src/Renderer/JSON.hs
View File

@ -7,8 +7,6 @@ module Renderer.JSON (
import Prologue hiding (toList)
import Alignment
import Category
import Control.Comonad.Cofree
import Control.Monad.Free
import Data.Aeson hiding (json)
import Data.Aeson.Encode
import Data.Bifunctor.Join
@ -18,7 +16,6 @@ import Data.Text.Lazy.Builder (toLazyText)
import qualified Data.Text as T
import Data.These
import Data.Vector hiding (toList)
import Diff
import Info
import Range
import Renderer
@ -28,7 +25,7 @@ import Syntax
import Term
-- | Render a diff to a string representing its JSON.
json :: Renderer a
json :: Renderer
json diff sources = toStrict . toLazyText . encodeToTextBuilder $ object ["rows" .= annotateRows (alignDiff (source <$> sources) diff), "oids" .= (oid <$> sources), "paths" .= (path <$> sources)]
where annotateRows = fmap (fmap NumberedLine) . numberedRows
@ -50,16 +47,18 @@ instance ToJSON a => ToJSON (Join (,) a) where
toJSON (Join (a, b)) = Array . fromList $ toJSON <$> [ a, b ]
toEncoding = foldable
instance ToJSON (SplitDiff leaf Info) where
toJSON (Free (Annotated info syntax)) = object (termFields info syntax)
toJSON (Pure patch) = object (patchFields patch)
toEncoding (Free (Annotated info syntax)) = pairs $ mconcat (termFields info syntax)
toEncoding (Pure patch) = pairs $ mconcat (patchFields patch)
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 value => ToJSON (OrderedMap T.Text value) where
toJSON kv = object $ uncurry (.=) <$> toList kv
toEncoding kv = pairs . mconcat $ uncurry (.=) <$> toList kv
instance ToJSON (Term leaf Info) where
toJSON (info :< syntax) = object (termFields info syntax)
toEncoding (info :< syntax) = pairs $ mconcat (termFields info syntax)
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 n term range = [ "number" .= n
@ -76,9 +75,9 @@ termFields (Info range categories _) syntax = "range" .= range : "categories" .=
Keyed c -> childrenFields c
where childrenFields c = [ "children" .= c ]
patchFields :: KeyValue kv => SplitPatch (Cofree (Syntax leaf) Info) -> [kv]
patchFields :: KeyValue kv => SplitPatch (Term leaf Info) -> [kv]
patchFields patch = case patch of
SplitInsert term -> fields "insert" term
SplitDelete term -> fields "delete" term
SplitReplace term -> fields "replace" term
where fields kind (info :< syntax) = "patch" .= T.pack kind : termFields info syntax
where fields kind term | (info :< syntax) <- runCofree term = "patch" .= T.pack kind : termFields info syntax

14
src/Renderer/Patch.hs
View File

@ -5,8 +5,13 @@ module Renderer.Patch (
truncatePatch
) where
import Data.String
import Alignment
import Data.Bifunctor.Join
import Data.Functor.Both as Both
import Data.List (span, unzip)
import Data.String
import Data.Text (pack)
import Data.These
import Diff
import Info
import Patch
@ -14,18 +19,13 @@ import Prologue hiding (fst, snd)
import Renderer
import Source hiding ((++), break)
import SplitDiff
import Data.Bifunctor.Join
import Data.Functor.Both as Both
import Data.List
import Data.Text (pack)
import Data.These
-- | 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"
-- | Render a diff in the traditional patch format.
patch :: Renderer a
patch :: Renderer
patch diff blobs = pack $ case getLast (foldMap (Last . Just) string) of
Just c | c /= '\n' -> string ++ "\n\\ No newline at end of file\n"
_ -> string

19
src/Renderer/Split.hs
View File

@ -4,16 +4,12 @@ module Renderer.Split where
import Data.String
import Alignment
import Category
import Control.Comonad.Cofree
import Control.Monad.Free
import Data.Bifunctor.Join
import Data.Foldable
import Data.Functor.Both
import Data.Maybe
import Data.Monoid
import Data.Functor.Foldable (cata)
import qualified Data.Text.Lazy as TL
import Data.These
import Diff
import Info
import Prologue hiding (div, head, fst, snd, link)
import qualified Prologue
@ -35,7 +31,7 @@ maybeFirst = foldr (const . Just) Nothing
-- | Add the first category from a Foldable of categories as a class name as a
-- | class name on the markup, prefixed by `category-`.
classifyMarkup :: Foldable f => f Category -> Markup -> Markup
classifyMarkup :: Prologue.Foldable f => f Category -> Markup -> Markup
classifyMarkup categories element = maybe element ((element !) . A.class_ . stringValue . styleName) $ maybeFirst categories
-- | Return the appropriate style name for the given category.
@ -59,7 +55,7 @@ splitPatchToClassName patch = stringValue $ "patch " ++ case patch of
SplitReplace _ -> "replace"
-- | Render a diff as an HTML split diff.
split :: Renderer leaf
split :: Renderer
split diff blobs = TL.toStrict . renderHtml
. docTypeHtml
. ((head $ link ! A.rel "stylesheet" ! A.href "style.css") <>)
@ -117,14 +113,13 @@ wrapIn _ l@Blaze.Comment{} = l
wrapIn f p = f p
instance ToMarkup (Renderable (Source Char, Term a Info)) where
toMarkup (Renderable (source, term)) = Prologue.fst $ cata (\ info@(Info range _ _) syntax -> (toMarkup $ Renderable (source, info, syntax), range)) term
toMarkup (Renderable (source, term)) = Prologue.fst $ cata (\ (info@(Info range _ _) :< syntax) -> (toMarkup $ Renderable (source, info, syntax), range)) term
instance ToMarkup (Renderable (Source Char, SplitDiff a Info)) where
toMarkup (Renderable (source, diff)) = Prologue.fst $ iter (\ (Annotated info@(Info range _ _) syntax) -> (toMarkup $ Renderable (source, info, syntax), range)) $ toMarkupAndRange <$> diff
toMarkup (Renderable (source, diff)) = Prologue.fst $ iter (\ (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 _ size :< _) = getSplitTerm patch in
((div ! A.class_ (splitPatchToClassName patch) ! A.data_ (stringValue (show size))) . toMarkup $ Renderable (source, term), range)
toMarkupAndRange patch = let term@(Info range _ size :< _) = runCofree $ getSplitTerm patch in
((div ! A.class_ (splitPatchToClassName patch) ! A.data_ (stringValue (show size))) . toMarkup $ Renderable (source, cofree term), range)
instance ToMarkup a => ToMarkup (Renderable (Bool, Int, a)) where
toMarkup (Renderable (hasChanges, num, line)) =

9
src/Renderer/Summary.hs Normal file
View File

@ -0,0 +1,9 @@
module Renderer.Summary where
import Prologue
import Renderer
import DiffSummary
import Data.Text (pack)
summary :: Renderer
summary diff sources = pack . show $ diffSummary diff

11
src/SES.hs
View File

@ -4,8 +4,7 @@ import Prologue
import Patch
import Diff
import Term
import Control.Monad.Free
import Data.Map as Map hiding (foldr)
import qualified Data.Map as Map
-- | A function that maybe creates a diff from two terms.
type Compare a annotation = Term a annotation -> Term a annotation -> Maybe (Diff a annotation)
@ -22,9 +21,9 @@ ses diffTerms cost as bs = fst <$> evalState diffState Map.empty where
diffAt :: Compare a annotation -> Cost a annotation -> (Integer, Integer) -> [Term a annotation] -> [Term a annotation] -> State (Map.Map (Integer, Integer) [(Diff a annotation, Integer)]) [(Diff a annotation, Integer)]
diffAt _ _ _ [] [] = pure []
diffAt _ cost _ [] bs = pure $ foldr toInsertions [] bs where
toInsertions each = consWithCost cost (Pure . Insert $ each)
toInsertions each = consWithCost cost (free . Pure . Insert $ each)
diffAt _ cost _ as [] = pure $ foldr toDeletions [] as where
toDeletions each = consWithCost cost (Pure . Delete $ each)
toDeletions each = consWithCost cost (free . Pure . Delete $ each)
diffAt diffTerms cost (i, j) (a : as) (b : bs) = do
cachedDiffs <- get
case Map.lookup (i, j) cachedDiffs of
@ -41,8 +40,8 @@ diffAt diffTerms cost (i, j) (a : as) (b : bs) = do
put $ Map.insert (i, j) nomination cachedDiffs'
pure nomination
where
delete = consWithCost cost (Pure . Delete $ a)
insert = consWithCost cost (Pure . Insert $ b)
delete = consWithCost cost (free . Pure . Delete $ a)
insert = consWithCost cost (free . Pure . Insert $ b)
costOf [] = 0
costOf ((_, c) : _) = c
best = minimumBy (comparing costOf)

13
src/SplitDiff.hs
View File

@ -1,12 +1,9 @@
module SplitDiff where
import Info
import Control.Comonad.Cofree ()
import Control.Monad.Free (Free(..))
import Data.Copointed
import Diff (Annotated(..))
import Range
import Prologue
import Syntax
import Term (Term)
-- | A patch to only one side of a diff.
@ -21,9 +18,9 @@ getSplitTerm (SplitReplace a) = a
-- | Get the range of a SplitDiff.
getRange :: SplitDiff leaf Info -> Range
getRange diff = characterRange $ case diff of
Free annotated -> annotation annotated
Pure patch -> copoint (getSplitTerm patch)
getRange diff = characterRange $ case runFree diff of
Free annotated -> headF annotated
Pure patch -> extract (getSplitTerm patch)
-- | A diff with only one side’s annotations.
type SplitDiff leaf annotation = Free (Annotated leaf annotation) (SplitPatch (Term leaf annotation))
type SplitDiff leaf annotation = Free (CofreeF (Syntax leaf) annotation) (SplitPatch (Term leaf annotation))

27
src/Term.hs
View File

@ -1,20 +1,27 @@
{-# LANGUAGE TypeFamilies, TypeSynonymInstances, FlexibleInstances #-}
module Term where
import Prologue
import Control.Comonad.Cofree
import Data.Functor.Foldable as Foldable
import Data.Functor.Both
import Data.OrderedMap hiding (size)
import Syntax
-- | An annotated node (Syntax) in an abstract syntax tree.
type TermF a annotation = CofreeF (Syntax a) annotation
type Term a annotation = Cofree (Syntax a) annotation
type instance Base (Cofree f a) = CofreeF f a
instance Functor f => Foldable.Foldable (Cofree f a) where project = runCofree
instance Functor f => Foldable.Unfoldable (Cofree f a) where embed = cofree
-- | 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 (Both annotation))
zipTerms (annotation1 :< a) (annotation2 :< b) = annotate $ zipUnwrap a b
zipTerms t1 t2 = annotate (zipUnwrap a b)
where
annotate = fmap (both annotation1 annotation2 :<)
(annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2)
annotate = fmap (cofree . (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'
@ -22,19 +29,7 @@ zipTerms (annotation1 :< a) (annotation2 :< b) = annotate $ zipUnwrap a b
zipUnwrap _ _ = Nothing
zipUnwrapMaps a' b' key = (,) key <$> zipTerms (a' ! key) (b' ! key)
-- | Fold a term into some other value, starting with the leaves.
cata :: Functor f => (annotation -> f a -> a) -> Cofree f annotation -> a
cata f = uncurry f . second (fmap (cata f)) . unCofree
-- | Unfold a term and its annotation starting from a seed value.
ana :: Functor f => (a -> (annotation, f a)) -> a -> Cofree f annotation
ana f = uncurry (:<) . second (fmap (ana f)) . f
-- | A hylomorphism. Given an `a`, unfold and then refold into a `b`.
hylo :: Functor f => (annotation -> f b -> b) -> (a -> (annotation, f a)) -> a -> b
hylo phi psi = cata phi . ana psi
-- | Return the node count of a term.
termSize :: Term a annotation -> Integer
termSize = cata size where
size _ syntax = 1 + sum syntax
size (_ :< syntax) = 1 + sum syntax

6
src/TreeSitter.hs
View File

@ -54,11 +54,11 @@ documentToTerm constructor document contents = alloca $ \ root -> do
name <- ts_node_p_name node document
name <- peekCString name
count <- ts_node_p_named_child_count node
children <- mapM (alloca . getChild node) $ take (fromIntegral count) [0..]
children <- traverse (alloca . getChild node) $ take (fromIntegral count) [0..]
-- Note: The strict application here is semantically important. Without it, we may not evaluate the range until after we’ve exited the scope that `node` was allocated within, meaning `alloca` will free it & other stack data may overwrite it.
range <- return $! Range { start = fromIntegral $ ts_node_p_start_char node, end = fromIntegral $ ts_node_p_end_char node }
range <- pure $! Range { start = fromIntegral $ ts_node_p_start_char node, end = fromIntegral $ ts_node_p_end_char node }
return $! constructor contents range name children
pure $! constructor contents range name children
getChild node n out = do
_ <- ts_node_p_named_child node n out
toTerm out

17
test/AlignmentSpec.hs
View File

@ -4,8 +4,6 @@ module AlignmentSpec where
import Alignment
import ArbitraryTerm ()
import Control.Arrow ((&&&))
import Control.Comonad.Cofree
import Control.Monad.Free
import Control.Monad.State
import Data.Align hiding (align)
import Data.Bifunctor
@ -278,7 +276,7 @@ instance Show a => Show (PrettyDiff a) where
pad n string = (++) (take n string) (replicate (max 0 (n - length string)) ' ')
toBoth them = showDiff <$> them `applyThese` modifyJoin (uncurry These) sources
newtype ConstructibleFree patch annotation = ConstructibleFree { deconstruct :: Free (Annotated String annotation) patch }
newtype ConstructibleFree patch annotation = ConstructibleFree { deconstruct :: Free (CofreeF (Syntax String) annotation) patch }
class PatchConstructible p where
@ -294,18 +292,17 @@ instance PatchConstructible (SplitPatch (Term String Info)) where
delete = SplitDelete
instance PatchConstructible patch => PatchConstructible (ConstructibleFree patch annotation) where
insert = ConstructibleFree . Pure . insert
delete = ConstructibleFree . Pure . delete
insert = ConstructibleFree . pure . insert
delete = ConstructibleFree . pure . delete
class SyntaxConstructible s where
leaf :: annotation -> String -> s annotation
branch :: annotation -> [s annotation] -> s annotation
instance SyntaxConstructible (ConstructibleFree patch) where
leaf info = ConstructibleFree . Free . Annotated info . Leaf
branch info = ConstructibleFree . Free . Annotated info . Indexed . fmap deconstruct
leaf info = ConstructibleFree . free . Free . (info :<) . Leaf
branch info = ConstructibleFree . free . Free . (info :<) . Indexed . fmap deconstruct
instance SyntaxConstructible (Cofree (Syntax String)) where
info `leaf` value = info :< Leaf value
info `branch` children = info :< Indexed children
info `leaf` value = cofree $ info :< Leaf value
info `branch` children = cofree $ info :< Indexed children

6
test/ArbitraryTerm.hs
View File

@ -3,10 +3,9 @@
module ArbitraryTerm where
import Category
import Control.Comonad.Cofree
import Control.Monad
import Data.Bifunctor.Join
import Data.Functor.Both
import Data.Functor.Foldable
import qualified Data.OrderedMap as Map
import qualified Data.List as List
import qualified Data.Set as Set
@ -18,7 +17,6 @@ import Prologue hiding (fst, snd)
import Range
import Source hiding ((++))
import Syntax
import GHC.Generics
import Term
import Test.QuickCheck hiding (Fixed)
@ -27,7 +25,7 @@ newtype ArbitraryTerm a annotation = ArbitraryTerm (annotation, Syntax a (Arbitr
unTerm :: ArbitraryTerm a annotation -> Term a annotation
unTerm = unfold unpack
where unpack (ArbitraryTerm (annotation, syntax)) = (annotation, syntax)
where unpack (ArbitraryTerm (annotation, syntax)) = annotation :< syntax
instance (Eq a, Eq annotation, Arbitrary a, Arbitrary annotation) => Arbitrary (ArbitraryTerm a annotation) where
arbitrary = scale (`div` 2) $ sized (\ x -> boundedTerm x x) -- first indicates the cube of the max length of lists, second indicates the cube of the max depth of the tree

6
test/CorpusSpec.hs
View File

@ -41,10 +41,10 @@ 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 a, Both FilePath, Maybe FilePath)]
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 a, Both FilePath, Maybe FilePath)]
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
@ -71,7 +71,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 T.Text -> Both FilePath -> Maybe FilePath -> (T.Text -> T.Text -> Expectation) -> Expectation
testDiff :: Renderer -> Both FilePath -> Maybe FilePath -> (T.Text -> T.Text -> Expectation) -> Expectation
testDiff renderer paths diff matcher = do
sources <- sequence $ readAndTranscodeFile <$> paths
actual <- diffFiles parser renderer (sourceBlobs sources)

39
test/DiffSummarySpec.hs Normal file
View File

@ -0,0 +1,39 @@
module DiffSummarySpec where
import Prologue
import Data.String
import Test.Hspec
import Diff
import Info
import Syntax
import Patch
import Range
import Category
import Data.Set
import DiffSummary
arrayInfo :: Info
arrayInfo = Info (rangeAt 0) (singleton ArrayLiteral) 2
literalInfo :: Info
literalInfo = Info (rangeAt 1) (singleton StringLiteral) 1
testDiff :: Diff String Info
testDiff = free $ Free (pure arrayInfo :< Indexed [ free $ Pure (Insert (cofree $ literalInfo :< Leaf "a")) ])
testSummary :: DiffSummary Char
testSummary = DiffSummary { patch = Insert (DiffInfo "string" (Just "a")), parentAnnotations = [] }
replacementSummary :: DiffSummary Char
replacementSummary = DiffSummary { patch = Replace (DiffInfo "string" (Just "a")) (DiffInfo "symbol" (Just "b")), parentAnnotations = [ (DiffInfo "array" (Just "switch {}")) ] }
spec :: Spec
spec = parallel $ do
describe "diffSummary" $ do
it "outputs a diff summary" $ do
diffSummary testDiff `shouldBe` [ DiffSummary { patch = Insert (DiffInfo "string" (Just "a")), parentAnnotations = [ DiffInfo "array" Nothing ] } ]
describe "show" $ do
it "should print adds" $
show testSummary `shouldBe` ("Added the 'a' string" :: String)
it "prints a replacement" $ do
show replacementSummary `shouldBe` ("Replaced the 'a' string with the 'b' symbol in the array context" :: String)

10
test/InterpreterSpec.hs
View File

@ -5,19 +5,17 @@ import Diff
import qualified Interpreter as I
import Range
import Syntax
import Control.Comonad.Cofree
import Control.Monad.Free
import Patch
import Info
import Category
import Test.Hspec
spec :: Spec
spec = parallel $ do
describe "interpret" $ do
spec = parallel $
describe "interpret" $
it "returns a replacement when comparing two unicode equivalent terms" $
I.interpret comparable diffCost (Info range mempty 0 :< Leaf "t\776") (Info range2 mempty 0 :< Leaf "\7831") `shouldBe`
Pure (Replace (Info range mempty 0 :< Leaf "t\776") (Info range2 mempty 0 :< Leaf "\7831"))
I.interpret comparable diffCost (cofree (Info range mempty 0 :< Leaf "t\776")) (cofree (Info range2 mempty 0 :< Leaf "\7831")) `shouldBe`
free (Pure (Replace (cofree (Info range mempty 0 :< Leaf "t\776")) (cofree (Info range2 mempty 0 :< Leaf "\7831"))))
where
range = Range 0 2

3
test/PatchOutputSpec.hs
View File

@ -1,7 +1,6 @@
module PatchOutputSpec where
import Prologue
import Control.Monad.Free
import Data.Functor.Both
import Data.String
import Diff
@ -16,4 +15,4 @@ spec :: Spec
spec = parallel $
describe "hunks" $
it "empty diffs have empty hunks" $
hunks (Free . Annotated (pure (Info (Range 0 0) mempty 1)) $ Leaf "" :: Diff String Info) (both (SourceBlob (fromList "") "abcde" "path2.txt" (Just defaultPlainBlob)) (SourceBlob (fromList "") "xyz" "path2.txt" (Just defaultPlainBlob))) `shouldBe` [Hunk {offset = pure 0, changes = [], trailingContext = []}]
hunks (free . Free $ pure (Info (Range 0 0) mempty 1) :< Leaf "") (both (SourceBlob (fromList "") "abcde" "path2.txt" (Just defaultPlainBlob)) (SourceBlob (fromList "") "xyz" "path2.txt" (Just defaultPlainBlob))) `shouldBe` [Hunk {offset = pure 0, changes = [], trailingContext = []}]

2
test/Spec.hs
View File

@ -7,6 +7,7 @@ import qualified InterpreterSpec
import qualified OrderedMapSpec
import qualified PatchOutputSpec
import qualified TermSpec
import qualified DiffSummarySpec
import Test.Hspec
main :: IO ()
@ -17,3 +18,4 @@ main = hspec $ parallel $ do
describe "OrderedMap" OrderedMapSpec.spec
describe "PatchOutput" PatchOutputSpec.spec
describe "Term" TermSpec.spec
describe "DiffSummary" DiffSummarySpec.spec