mirror of
https://github.com/github/semantic.git
synced 2024-12-30 10:27:45 +03:00
Merge branch 'master' into profiling-improvements
This commit is contained in:
Rob Rix
commit
e85e09b25d
10
UI/style.css
10
UI/style.css
@ -81,12 +81,14 @@ body {
|
||||
padding: 0;
|
||||
font-family: monospace;
|
||||
}
|
||||
.blob-code-replacement:last-child .insert,
|
||||
.blob-code-replacement:last-child .replace {
|
||||
.blob-code:last-child .patch,
|
||||
.blob-code:last-child .insert,
|
||||
.blob-code:last-child .replace {
|
||||
background-color: #a6f3a6;
|
||||
}
|
||||
.blob-code-replacement .delete,
|
||||
.blob-code-replacement .replace {
|
||||
.blob-code .patch,
|
||||
.blob-code .delete,
|
||||
.blob-code .replace {
|
||||
background-color: #f8cbcb;
|
||||
}
|
||||
|
||||
|
||||
@ -18,6 +18,8 @@ library
|
||||
, Operation
|
||||
, Algorithm
|
||||
, Interpreter
|
||||
, Line
|
||||
, Row
|
||||
, OrderedMap
|
||||
, Patch
|
||||
, SES
|
||||
@ -78,6 +80,7 @@ test-suite semantic-diff-test
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
other-modules: ArbitraryTerm
|
||||
build-depends: base
|
||||
, containers
|
||||
, free
|
||||
|
||||
45
src/Line.hs
Normal file
45
src/Line.hs
Normal file
@ -0,0 +1,45 @@
|
||||
module Line where
|
||||
|
||||
import Data.Monoid
|
||||
import Data.List (intercalate)
|
||||
import Text.Blaze.Html5 hiding (map)
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
|
||||
data Line a =
|
||||
Line [a]
|
||||
| EmptyLine
|
||||
deriving (Eq, Functor, Foldable)
|
||||
|
||||
unLine :: Line a -> [a]
|
||||
unLine EmptyLine = []
|
||||
unLine (Line elements) = elements
|
||||
|
||||
maybeLast :: Foldable f => f a -> Maybe a
|
||||
maybeLast = foldl (flip $ const . Just) Nothing
|
||||
|
||||
openLineBy :: (a -> Maybe a) -> [Line a] -> Maybe (Line a)
|
||||
openLineBy _ [] = Nothing
|
||||
openLineBy f (EmptyLine : rest) = openLineBy f rest
|
||||
openLineBy f (line : _) = const line <$> (f =<< maybeLast (unLine line))
|
||||
|
||||
adjoinLinesBy :: (a -> Maybe a) -> [Line a] -> Line a -> [Line a]
|
||||
adjoinLinesBy _ [] line = [line]
|
||||
adjoinLinesBy f (EmptyLine : xs) line | Just _ <- openLineBy f xs = EmptyLine : adjoinLinesBy f xs line
|
||||
adjoinLinesBy f (prev:rest) line | Just _ <- openLineBy f [ prev ] = (prev <> line) : rest
|
||||
adjoinLinesBy _ lines line = line : lines
|
||||
|
||||
instance Show a => Show (Line a) where
|
||||
show (Line elements) = "[" ++ intercalate ", " (show <$> elements) ++ "]"
|
||||
show EmptyLine = "EmptyLine"
|
||||
|
||||
instance Monoid (Line a) where
|
||||
mempty = EmptyLine
|
||||
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 $ toMarkup <$> contents) ! A.class_ (stringValue $ if hasChanges then "blob-code blob-code-replacement" else "blob-code") <> string "\n"
|
||||
@ -13,11 +13,17 @@ module OrderedMap (
|
||||
, difference
|
||||
) where
|
||||
|
||||
import qualified Data.Maybe as Maybe
|
||||
|
||||
data OrderedMap key value = OrderedMap { toList :: [(key, value)] }
|
||||
deriving (Show, Eq, Functor, Foldable, Traversable)
|
||||
|
||||
instance Eq key => Monoid (OrderedMap key value) where
|
||||
mempty = fromList []
|
||||
mappend = union
|
||||
|
||||
fromList :: [(key, value)] -> OrderedMap key value
|
||||
fromList list = OrderedMap list
|
||||
fromList = OrderedMap
|
||||
|
||||
keys :: OrderedMap key value -> [key]
|
||||
keys (OrderedMap pairs) = fst <$> pairs
|
||||
@ -25,9 +31,7 @@ keys (OrderedMap pairs) = fst <$> pairs
|
||||
infixl 9 !
|
||||
|
||||
(!) :: Eq key => OrderedMap key value -> key -> value
|
||||
map ! key = case OrderedMap.lookup key map of
|
||||
Just value -> value
|
||||
Nothing -> error "no value found for key"
|
||||
map ! key = Maybe.fromMaybe (error "no value found for key") $ OrderedMap.lookup key map
|
||||
|
||||
lookup :: Eq key => key -> OrderedMap key value -> Maybe value
|
||||
lookup key = Prelude.lookup key . toList
|
||||
@ -46,7 +50,7 @@ unions :: Eq key => [OrderedMap key value] -> OrderedMap key value
|
||||
unions = foldl union empty
|
||||
|
||||
intersectionWith :: Eq key => (a -> b -> c) -> OrderedMap key a -> OrderedMap key b -> OrderedMap key c
|
||||
intersectionWith combine (OrderedMap a) (OrderedMap b) = OrderedMap $ a >>= (\ (key, value) -> maybe [] (pure . ((,) key) . combine value) $ Prelude.lookup key b)
|
||||
intersectionWith combine (OrderedMap a) (OrderedMap b) = OrderedMap $ a >>= (\ (key, value) -> maybe [] (pure . (,) key . combine value) $ Prelude.lookup key b)
|
||||
|
||||
difference :: Eq key => OrderedMap key a -> OrderedMap key b -> OrderedMap key a
|
||||
difference (OrderedMap a) (OrderedMap b) = OrderedMap $ filter (not . (`elem` extant) . fst) a
|
||||
|
||||
@ -4,6 +4,7 @@ import Control.Applicative ((<|>))
|
||||
import qualified Data.Char as Char
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
-- | A half-open interval of integers, defined by start & end indices.
|
||||
data Range = Range { start :: !Int, end :: !Int }
|
||||
deriving (Eq, Show)
|
||||
|
||||
@ -35,6 +36,10 @@ rangesAndWordsFrom startIndex string = fromMaybe [] $ takeAndContinue <$> (word
|
||||
-- | > A member of one of the following Unicode general category _Letter_, _Mark_, _Number_, _Connector_Punctuation_
|
||||
isWord c = Char.isLetter c || Char.isNumber c || Char.isMark c || Char.generalCategory c == Char.ConnectorPunctuation
|
||||
|
||||
-- | Return Just the last index from a non-empty range, or if the range is empty, Nothing.
|
||||
maybeLastIndex :: Range -> Maybe Int
|
||||
maybeLastIndex (Range start end) | start == end = Nothing
|
||||
maybeLastIndex (Range _ end) = Just $ end - 1
|
||||
|
||||
instance Ord Range where
|
||||
a <= b = start a <= start b
|
||||
|
||||
33
src/Row.hs
Normal file
33
src/Row.hs
Normal file
@ -0,0 +1,33 @@
|
||||
module Row where
|
||||
|
||||
import Line
|
||||
|
||||
data Row a = Row { unLeft :: Line a, unRight :: Line a }
|
||||
deriving (Eq, Functor)
|
||||
|
||||
adjoinRowsBy :: (a -> Maybe a) -> (a -> Maybe 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 rights
|
||||
where lefts = adjoinLinesBy f (unLeft <$> rows) left'
|
||||
rights = adjoinLinesBy g (unRight <$> rows) right'
|
||||
|
||||
adjoinRowsBy f _ rows (Row left' right') | Just _ <- openLineBy f $ unLeft <$> rows = case right' of
|
||||
EmptyLine -> rest
|
||||
_ -> Row EmptyLine right' : rest
|
||||
where rest = zipWith Row lefts rights
|
||||
lefts = adjoinLinesBy f (unLeft <$> rows) left'
|
||||
rights = unRight <$> rows
|
||||
|
||||
adjoinRowsBy _ g rows (Row left' right') | Just _ <- openLineBy g $ unRight <$> rows = case left' of
|
||||
EmptyLine -> rest
|
||||
_ -> Row left' EmptyLine : rest
|
||||
where rest = zipWith Row lefts rights
|
||||
lefts = unLeft <$> rows
|
||||
rights = adjoinLinesBy g (unRight <$> rows) right'
|
||||
|
||||
adjoinRowsBy _ _ rows row = row : rows
|
||||
|
||||
|
||||
instance Show a => Show (Row a) where
|
||||
show (Row left right) = "\n" ++ show left ++ " | " ++ show right
|
||||
345
src/Split.hs
345
src/Split.hs
@ -2,10 +2,11 @@ module Split where
|
||||
|
||||
import Prelude hiding (div, head, span)
|
||||
import Diff
|
||||
import Line
|
||||
import Row
|
||||
import Patch
|
||||
import Term
|
||||
import Syntax
|
||||
|
||||
import Control.Comonad.Cofree
|
||||
import Range
|
||||
import Control.Monad.Free
|
||||
@ -14,48 +15,13 @@ import Text.Blaze.Html
|
||||
import Text.Blaze.Html5 hiding (map)
|
||||
import qualified Text.Blaze.Html5.Attributes as A
|
||||
import Text.Blaze.Html.Renderer.Utf8
|
||||
import qualified OrderedMap as Map
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import qualified Data.Set as Set
|
||||
import Debug.Trace
|
||||
import Data.List (intersperse)
|
||||
|
||||
type ClassName = String
|
||||
|
||||
data HTML =
|
||||
Break
|
||||
| Text String
|
||||
| Span (Maybe ClassName) String
|
||||
| Ul (Maybe ClassName) [HTML]
|
||||
| Dl (Maybe ClassName) [HTML]
|
||||
| Div (Maybe ClassName) [HTML]
|
||||
| Dt String
|
||||
deriving (Show, Eq)
|
||||
|
||||
classifyMarkup :: Maybe ClassName -> Markup -> Markup
|
||||
classifyMarkup (Just className) element = element ! A.class_ (stringValue className)
|
||||
classifyMarkup _ element = element
|
||||
|
||||
toLi :: HTML -> Markup
|
||||
toLi (Text s) = string s
|
||||
toLi e = li $ toMarkup e
|
||||
|
||||
toDd :: HTML -> Markup
|
||||
toDd (Text s) = string s
|
||||
toDd e = dd $ toMarkup e
|
||||
|
||||
instance ToMarkup HTML where
|
||||
toMarkup Break = br
|
||||
toMarkup (Text s) = string s
|
||||
toMarkup (Span className s) = classifyMarkup className . span $ string s
|
||||
toMarkup (Ul className children) = classifyMarkup className . ul $ mconcat (toLi <$> children)
|
||||
toMarkup (Dl className children) = classifyMarkup className . dl $ mconcat (toDd <$> children)
|
||||
toMarkup (Div className children) = classifyMarkup className . div $ mconcat (toMarkup <$> children)
|
||||
toMarkup (Dt key) = dt $ string key
|
||||
|
||||
trace' :: Show a => a -> a
|
||||
trace' a = traceShow a a
|
||||
classifyMarkup :: Foldable f => f String -> Markup -> Markup
|
||||
classifyMarkup categories element = maybe element ((element !) . A.class_ . stringValue . ("category-" ++)) $ maybeLast categories
|
||||
|
||||
split :: Diff a Info -> String -> String -> IO ByteString
|
||||
split diff before after = return . renderHtml
|
||||
@ -63,10 +29,10 @@ split diff before after = return . renderHtml
|
||||
. ((head $ link ! A.rel (stringValue "stylesheet") ! A.href (stringValue "style.css")) <>)
|
||||
. body
|
||||
. (table ! A.class_ (stringValue "diff")) $
|
||||
((<>) (colgroup $ (col ! A.width (stringValue . show $ columnWidth)) <> col <> (col ! A.width (stringValue . show $ columnWidth)) <> col))
|
||||
. mconcat $ toMarkup <$> reverse numbered
|
||||
((colgroup $ (col ! A.width (stringValue . show $ columnWidth)) <> col <> (col ! A.width (stringValue . show $ columnWidth)) <> col) <>)
|
||||
. mconcat $ numberedLinesToMarkup <$> reverse numbered
|
||||
where
|
||||
rows = fst $ diffToRows diff (0, 0) before after
|
||||
rows = fst (splitDiffByLines diff (0, 0) (before, after))
|
||||
numbered = foldl numberRows [] rows
|
||||
maxNumber = case numbered of
|
||||
[] -> 0
|
||||
@ -74,237 +40,124 @@ split diff before after = return . renderHtml
|
||||
|
||||
digits :: Int -> Int
|
||||
digits n = let base = 10 :: Int in
|
||||
ceiling (log(fromIntegral n) / log(fromIntegral base) :: Double)
|
||||
ceiling (logBase (fromIntegral base) (fromIntegral n) :: Double)
|
||||
|
||||
columnWidth = max (20 + digits maxNumber * 8) 40
|
||||
|
||||
numberRows :: [(Int, Line, Int, Line)] -> Row -> [(Int, Line, Int, Line)]
|
||||
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"
|
||||
|
||||
renderable source = fmap (Renderable . (,) source)
|
||||
|
||||
hasChanges diff = or $ const True <$> diff
|
||||
|
||||
numberRows :: [(Int, Line a, Int, Line a)] -> Row a -> [(Int, Line a, Int, Line a)]
|
||||
numberRows [] (Row EmptyLine EmptyLine) = []
|
||||
numberRows [] (Row left@(Line _ _) EmptyLine) = [(1, left, 0, EmptyLine)]
|
||||
numberRows [] (Row EmptyLine right@(Line _ _)) = [(0, EmptyLine, 1, right)]
|
||||
numberRows [] (Row left@(Line _) EmptyLine) = [(1, left, 0, EmptyLine)]
|
||||
numberRows [] (Row EmptyLine right@(Line _)) = [(0, EmptyLine, 1, right)]
|
||||
numberRows [] (Row left right) = [(1, left, 1, right)]
|
||||
numberRows rows@((leftCount, _, rightCount, _):_) (Row EmptyLine EmptyLine) = (leftCount, EmptyLine, rightCount, EmptyLine):rows
|
||||
numberRows rows@((leftCount, _, rightCount, _):_) (Row left@(Line _ _) EmptyLine) = (leftCount + 1, left, rightCount, EmptyLine):rows
|
||||
numberRows rows@((leftCount, _, rightCount, _):_) (Row EmptyLine right@(Line _ _)) = (leftCount, EmptyLine, rightCount + 1, right):rows
|
||||
numberRows rows@((leftCount, _, rightCount, _):_) (Row left@(Line _) EmptyLine) = (leftCount + 1, left, rightCount, EmptyLine):rows
|
||||
numberRows rows@((leftCount, _, rightCount, _):_) (Row EmptyLine right@(Line _)) = (leftCount, EmptyLine, rightCount + 1, right):rows
|
||||
numberRows rows@((leftCount, _, rightCount, _):_) (Row left right) = (leftCount + 1, left, rightCount + 1, right):rows
|
||||
|
||||
-- | A diff with only one side’s annotations.
|
||||
type SplitDiff leaf annotation = Free (Annotated leaf annotation) (Term leaf annotation)
|
||||
|
||||
data Row = Row Line Line
|
||||
deriving Eq
|
||||
newtype Renderable a = Renderable (String, a)
|
||||
|
||||
instance Show Row where
|
||||
show (Row left right) = "\n" ++ show left ++ " | " ++ show right
|
||||
instance ToMarkup f => ToMarkup (Renderable (Info, Syntax a (f, Range))) where
|
||||
toMarkup (Renderable (source, (Info range categories, syntax))) = classifyMarkup categories $ case syntax of
|
||||
Leaf _ -> span . string $ substring range source
|
||||
Indexed children -> ul . mconcat $ contentElements children
|
||||
Fixed children -> ul . mconcat $ contentElements children
|
||||
Keyed children -> dl . mconcat $ contentElements children
|
||||
where markupForSeparatorAndChild :: ToMarkup f => ([Markup], Int) -> (f, Range) -> ([Markup], Int)
|
||||
markupForSeparatorAndChild (rows, previous) child = (rows ++ [ string (substring (Range previous $ start $ snd child) source), toMarkup $ fst child ], end $ snd child)
|
||||
|
||||
instance ToMarkup (Int, Line, Int, Line) where
|
||||
toMarkup (m, left, n, right) = tr $ toMarkup (m, left) <> toMarkup (n, right) <> string "\n"
|
||||
contentElements children = let (elements, previous) = foldl markupForSeparatorAndChild ([], start range) children in
|
||||
elements ++ [ string $ substring (Range previous $ end range) source ]
|
||||
|
||||
instance ToMarkup (Int, Line) where
|
||||
toMarkup (_, EmptyLine) = numberTd "" <> toMarkup EmptyLine <> string "\n"
|
||||
toMarkup (num, line@(Line True _)) = td (string $ show num) ! A.class_ (stringValue "blob-num blob-num-replacement") <> toMarkup line <> string "\n"
|
||||
toMarkup (num, line@(Line _ _)) = numberTd (show num) <> toMarkup line <> string "\n"
|
||||
instance ToMarkup (Renderable (Term a Info)) where
|
||||
toMarkup (Renderable (source, term)) = fst $ cata (\ info@(Info range _) syntax -> (toMarkup $ Renderable (source, (info, syntax)), range)) term
|
||||
|
||||
numberTd :: String -> Html
|
||||
numberTd "" = td mempty ! A.class_ (stringValue "blob-num blob-num-empty empty-cell")
|
||||
numberTd s = td (string s) ! A.class_ (stringValue "blob-num")
|
||||
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
|
||||
where toMarkupAndRange :: Term a Info -> (Markup, Range)
|
||||
toMarkupAndRange term@(Info range _ :< _) = ((div ! A.class_ (stringValue "patch")) . toMarkup $ Renderable (source, term), range)
|
||||
|
||||
codeTd :: Bool -> Maybe Html -> Html
|
||||
codeTd _ Nothing = td mempty ! A.class_ (stringValue "blob-code blob-code-empty empty-cell")
|
||||
codeTd True (Just el) = td el ! A.class_ (stringValue "blob-code blob-code-replacement")
|
||||
codeTd _ (Just el) = td el ! A.class_ (stringValue "blob-code")
|
||||
splitDiffByLines :: Diff a Info -> (Int, Int) -> (String, String) -> ([Row (SplitDiff a Info)], (Range, Range))
|
||||
splitDiffByLines diff (prevLeft, prevRight) 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 <$> lines, (Range prevLeft prevLeft, range))
|
||||
Pure (Delete term) -> let (lines, range) = splitTermByLines term (fst sources) in
|
||||
(flip Row EmptyLine . fmap Pure <$> 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 <$> leftLines) (fmap Pure <$> rightLines), (leftRange, rightRange))
|
||||
where categories (Info _ left, Info _ right) = (left, right)
|
||||
ranges (Info left _, Info right _) = (left, right)
|
||||
|
||||
instance ToMarkup Line where
|
||||
toMarkup EmptyLine = codeTd False Nothing
|
||||
toMarkup (Line changed html) = codeTd changed . Just . mconcat $ toMarkup <$> html
|
||||
-- | Takes a term and a source and returns a list of lines and their range within source.
|
||||
splitTermByLines :: Term a Info -> String -> ([Line (Term a Info)], Range)
|
||||
splitTermByLines (Info range categories :< syntax) source = flip (,) range $ case syntax of
|
||||
Leaf a -> contextLines (:< Leaf a) range categories source
|
||||
Indexed children -> adjoinChildLines Indexed children
|
||||
Fixed children -> adjoinChildLines Fixed children
|
||||
Keyed children -> adjoinChildLines Keyed children
|
||||
where adjoin = reverse . foldl (adjoinLinesBy $ openTerm source) []
|
||||
adjoinChildLines constructor children = let (lines, previous) = foldl (childLines $ constructor mempty) ([], start range) children in
|
||||
adjoin $ lines ++ contextLines (:< constructor mempty) (Range previous $ end range) categories source
|
||||
|
||||
data Line =
|
||||
Line Bool [HTML]
|
||||
| EmptyLine
|
||||
deriving Eq
|
||||
childLines constructor (lines, previous) child = let (childLines, childRange) = splitTermByLines child source in
|
||||
(adjoin $ lines ++ contextLines (:< constructor) (Range previous $ start childRange) categories source ++ childLines, end childRange)
|
||||
|
||||
unLine :: Line -> [HTML]
|
||||
unLine EmptyLine = []
|
||||
unLine (Line _ htmls) = htmls
|
||||
splitAnnotatedByLines :: (String, String) -> (Range, Range) -> (Set.Set Category, Set.Set Category) -> Syntax a (Diff a Info) -> [Row (SplitDiff a Info)]
|
||||
splitAnnotatedByLines sources ranges categories syntax = case syntax of
|
||||
Leaf a -> contextRows (Leaf a) ranges categories sources
|
||||
Indexed children -> adjoinChildRows Indexed children
|
||||
Fixed children -> adjoinChildRows Fixed children
|
||||
Keyed children -> adjoinChildRows Keyed children
|
||||
where contextRows constructor ranges categories sources = zipWithDefaults Row EmptyLine EmptyLine (contextLines (Free . (`Annotated` constructor)) (fst ranges) (fst categories) (fst sources)) (contextLines (Free . (`Annotated` constructor)) (snd ranges) (snd categories) (snd sources))
|
||||
|
||||
isChanged :: Line -> Bool
|
||||
isChanged EmptyLine = False
|
||||
isChanged (Line isChanged _) = isChanged
|
||||
adjoin = reverse . foldl (adjoinRowsBy (openDiff $ fst sources) (openDiff $ snd sources)) []
|
||||
adjoinChildRows constructor children = let (rows, previous) = foldl (childRows $ constructor mempty) ([], starts ranges) children in
|
||||
adjoin $ rows ++ contextRows (constructor mempty) (makeRanges previous (ends ranges)) categories sources
|
||||
|
||||
instance Show Line where
|
||||
show (Line change elements) = show change ++ " [" ++ (concat . intersperse ", " $ show <$> elements) ++ "]"
|
||||
show EmptyLine = "EmptyLine"
|
||||
childRows constructor (rows, previous) child = let (childRows, childRanges) = splitDiffByLines child previous sources in
|
||||
(adjoin $ rows ++ contextRows constructor (makeRanges previous (starts childRanges)) categories sources ++ childRows, ends childRanges)
|
||||
|
||||
instance Monoid Line where
|
||||
mempty = EmptyLine
|
||||
mappend EmptyLine EmptyLine = EmptyLine
|
||||
mappend EmptyLine (Line c ys) = Line c ys
|
||||
mappend (Line c xs) EmptyLine = Line c xs
|
||||
mappend (Line c1 xs) (Line c2 ys) = Line (c1 || c2) (xs <> ys)
|
||||
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)
|
||||
|
||||
instance Monoid Row where
|
||||
mempty = Row EmptyLine EmptyLine
|
||||
mappend (Row x1 y1) (Row x2 y2) = Row (x1 <> x2) (y1 <> y2)
|
||||
contextLines :: (Info -> a) -> Range -> Set.Set Category -> String -> [Line a]
|
||||
contextLines constructor range categories source = Line . (:[]) . constructor . (`Info` categories) <$> actualLineRanges range source
|
||||
|
||||
diffToRows :: Diff a Info -> (Int, Int) -> String -> String -> ([Row], (Range, Range))
|
||||
diffToRows (Free annotated) _ before after = annotatedToRows annotated before after
|
||||
diffToRows (Pure (Insert term)) (previousIndex, _) _ after = (rowWithInsertedLine <$> afterLines, (Range previousIndex previousIndex, range))
|
||||
where
|
||||
(afterLines, range) = termToLines term after
|
||||
rowWithInsertedLine (Line _ elements) = Row EmptyLine $ Line True [ Div (Just "insert") elements ]
|
||||
rowWithInsertedLine EmptyLine = mempty
|
||||
diffToRows (Pure (Delete term)) (_, previousIndex) before _ = (rowWithDeletedLine <$> lines, (range, Range previousIndex previousIndex))
|
||||
where
|
||||
(lines, range) = termToLines term before
|
||||
rowWithDeletedLine (Line _ elements) = Row (Line True [ Div (Just "delete") elements ]) EmptyLine
|
||||
rowWithDeletedLine EmptyLine = mempty
|
||||
diffToRows (Pure (Replace a b)) _ before after = (replacedRows, (leftRange, rightRange))
|
||||
where
|
||||
replacedRows = zipWithMaybe rowFromMaybeRows (replace <$> leftElements) (replace <$> rightElements)
|
||||
replace = (:[]) . Div (Just "replace") . unLine
|
||||
rowFromMaybeRows :: Maybe [HTML] -> Maybe [HTML] -> Row
|
||||
rowFromMaybeRows a b = Row (maybe EmptyLine (Line True) a) (maybe EmptyLine (Line True) b)
|
||||
(leftElements, leftRange) = termToLines a before
|
||||
(rightElements, rightRange) = termToLines b after
|
||||
openRange :: String -> Range -> Maybe Range
|
||||
openRange source range = case (source !!) <$> maybeLastIndex range of
|
||||
Just '\n' -> Nothing
|
||||
_ -> Just range
|
||||
|
||||
-- | Takes a term and a `source` and returns a list of HTML lines
|
||||
-- | and their range within `source`.
|
||||
termToLines :: Term a Info -> String -> ([Line], Range)
|
||||
termToLines (Info range categories :< syntax) source = (rows syntax, range)
|
||||
where
|
||||
rows (Leaf _) = reverse $ foldl adjoin2Lines [] $ Line True . (:[]) <$> elements
|
||||
rows (Indexed i) = rewrapLineContentsIn Ul <$> childLines i
|
||||
rows (Fixed f) = rewrapLineContentsIn Ul <$> childLines f
|
||||
rows (Keyed k) = rewrapLineContentsIn Dl <$> childLines k
|
||||
openTerm :: String -> Term a Info -> Maybe (Term a Info)
|
||||
openTerm source term@(Info range _ :< _) = const term <$> openRange source range
|
||||
|
||||
rewrapLineContentsIn f (Line _ elements) = Line True [ f (classify categories) elements ]
|
||||
rewrapLineContentsIn _ EmptyLine = EmptyLine
|
||||
lineElements r s = Line True . (:[]) <$> textElements r s
|
||||
childLines i = appendRemainder $ foldl sumLines ([], start range) i
|
||||
appendRemainder (lines, previous) = reverse . foldl adjoin2Lines [] $ lines ++ lineElements (Range previous (end range)) source
|
||||
sumLines (lines, previous) child = (allLines, end childRange)
|
||||
where
|
||||
separatorLines = lineElements (Range previous $ start childRange) source
|
||||
unadjoinedLines = lines ++ separatorLines ++ childLines
|
||||
allLines = reverse $ foldl adjoin2Lines [] unadjoinedLines
|
||||
(childLines, childRange) = termToLines child source
|
||||
elements = (elementAndBreak $ Span (classify categories)) =<< actualLines (substring range source)
|
||||
openDiff :: String -> SplitDiff a Info -> Maybe (SplitDiff a Info)
|
||||
openDiff source diff@(Free (Annotated (Info range _) _)) = const diff <$> openRange source range
|
||||
openDiff source diff@(Pure term) = const diff <$> openTerm source term
|
||||
|
||||
-- | Given an Annotated and before/after strings, returns a list of `Row`s representing the newline-separated diff.
|
||||
annotatedToRows :: Annotated a (Info, Info) (Diff a Info) -> String -> String -> ([Row], (Range, Range))
|
||||
annotatedToRows (Annotated (Info left leftCategories, Info right rightCategories) syntax) before after = (rows syntax, ranges)
|
||||
where
|
||||
rows (Leaf _) = zipWithMaybe rowFromMaybeRows leftElements rightElements
|
||||
rows (Indexed i) = rewrapRowContentsIn Ul <$> childRows i
|
||||
rows (Fixed f) = rewrapRowContentsIn Ul <$> childRows f
|
||||
rows (Keyed k) = rewrapRowContentsIn Dl <$> childRows (snd <$> Map.toList k)
|
||||
|
||||
leftElements = (elementAndBreak $ Span (classify leftCategories)) =<< actualLines (substring left before)
|
||||
rightElements = (elementAndBreak $ Span (classify rightCategories)) =<< actualLines (substring right after)
|
||||
|
||||
wrap _ EmptyLine = EmptyLine
|
||||
wrap f (Line c elements) = Line c [ f elements ]
|
||||
rewrapRowContentsIn f (Row left right) = Row (wrap (f $ classify leftCategories) left) (wrap (f $ classify rightCategories) right)
|
||||
ranges = (left, right)
|
||||
sources = (before, after)
|
||||
childRows = appendRemainder . foldl sumRows ([], starts ranges)
|
||||
appendRemainder (rows, previousIndices) = reverse . foldl adjoin2 [] $ rows ++ (contextRows (ends ranges) previousIndices sources)
|
||||
sumRows (rows, previousIndices) child = (allRows, ends childRanges)
|
||||
where
|
||||
separatorRows = contextRows (starts childRanges) previousIndices sources
|
||||
allRows = rows ++ separatorRows ++ childRows
|
||||
(childRows, childRanges) = diffToRows child previousIndices before after
|
||||
|
||||
contextRows :: (Int, Int) -> (Int, Int) -> (String, String) -> [Row]
|
||||
contextRows childIndices previousIndices sources = zipWithMaybe rowFromMaybeRows leftElements rightElements
|
||||
where
|
||||
leftElements = textElements (Range (fst previousIndices) (fst childIndices)) (fst sources)
|
||||
rightElements = textElements (Range (snd previousIndices) (snd childIndices)) (snd sources)
|
||||
|
||||
elementAndBreak :: (String -> HTML) -> String -> [HTML]
|
||||
elementAndBreak _ "" = []
|
||||
elementAndBreak _ "\n" = [ Break ]
|
||||
elementAndBreak constructor x | '\n' <- last x = [ constructor $ init x, Break ]
|
||||
elementAndBreak constructor x = [ constructor x ]
|
||||
|
||||
textElements :: Range -> String -> [HTML]
|
||||
textElements range source = (elementAndBreak Text) =<< actualLines s
|
||||
where s = substring range source
|
||||
|
||||
starts :: (Range , Range) -> (Int, Int)
|
||||
starts (left, right) = (start left, start right)
|
||||
|
||||
ends :: (Range, Range) -> (Int, Int)
|
||||
ends (left, right) = (end left, end right)
|
||||
|
||||
rowFromMaybeRows :: Maybe HTML -> Maybe HTML -> Row
|
||||
rowFromMaybeRows a b = Row (maybe EmptyLine (Line False . (:[])) a) (maybe EmptyLine (Line False . (:[])) b)
|
||||
|
||||
maybeLast :: [a] -> Maybe a
|
||||
maybeLast list = listToMaybe $ reverse list
|
||||
|
||||
adjoin2 :: [Row] -> Row -> [Row]
|
||||
adjoin2 [] row = [row]
|
||||
|
||||
adjoin2 rows (Row left' right') | Just _ <- openLine $ leftLines rows, Just _ <- openLine $ rightLines rows = zipWith Row lefts rights
|
||||
where lefts = adjoin2Lines (leftLines rows) left'
|
||||
rights = adjoin2Lines (rightLines rows) right'
|
||||
|
||||
adjoin2 rows (Row left' right') | Just _ <- openLine $ leftLines rows = case right' of
|
||||
EmptyLine -> rest
|
||||
_ -> Row EmptyLine right' : rest
|
||||
where rest = zipWith Row lefts rights
|
||||
lefts = adjoin2Lines (leftLines rows) left'
|
||||
rights = rightLines rows
|
||||
|
||||
adjoin2 rows (Row left' right') | Just _ <- openLine $ rightLines rows = case left' of
|
||||
EmptyLine -> rest
|
||||
_ -> Row left' EmptyLine : rest
|
||||
where rest = zipWith Row lefts rights
|
||||
lefts = leftLines rows
|
||||
rights = adjoin2Lines (rightLines rows) right'
|
||||
|
||||
adjoin2 rows row = row : rows
|
||||
|
||||
leftLines :: [Row] -> [Line]
|
||||
leftLines rows = left <$> rows
|
||||
where
|
||||
left (Row left _) = left
|
||||
|
||||
rightLines :: [Row] -> [Line]
|
||||
rightLines rows = right <$> rows
|
||||
where
|
||||
right (Row _ right) = right
|
||||
|
||||
openElement :: HTML -> Maybe HTML
|
||||
openElement Break = Nothing
|
||||
openElement (Ul _ elements) = openElement =<< maybeLast elements
|
||||
openElement (Dl _ elements) = openElement =<< maybeLast elements
|
||||
openElement (Div _ elements) = openElement =<< maybeLast elements
|
||||
openElement h = Just h
|
||||
|
||||
openLine :: [Line] -> Maybe Line
|
||||
openLine [] = Nothing
|
||||
openLine (EmptyLine : rest) = openLine rest
|
||||
openLine (line : _) = const line <$> (openElement =<< (maybeLast $ unLine line))
|
||||
|
||||
adjoin2Lines :: [Line] -> Line -> [Line]
|
||||
adjoin2Lines [] line = [line]
|
||||
adjoin2Lines (EmptyLine : xs) line | Just _ <- openLine xs = EmptyLine : adjoin2Lines xs line
|
||||
adjoin2Lines (prev:rest) line | Just _ <- openLine [ prev ] = (prev <> line) : rest
|
||||
adjoin2Lines lines line = line : lines
|
||||
|
||||
zipWithMaybe :: (Maybe a -> Maybe b -> c) -> [a] -> [b] -> [c]
|
||||
zipWithMaybe f la lb = take len $ zipWith f la' lb'
|
||||
where
|
||||
len = max (length la) (length lb)
|
||||
la' = (Just <$> la) ++ (repeat Nothing)
|
||||
lb' = (Just <$> lb) ++ (repeat Nothing)
|
||||
|
||||
classify :: Set.Set Category -> Maybe ClassName
|
||||
classify = foldr (const . Just . ("category-" ++)) Nothing
|
||||
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)
|
||||
|
||||
actualLines :: String -> [String]
|
||||
actualLines "" = [""]
|
||||
actualLines lines = case break (== '\n') lines of
|
||||
(l, lines') -> (case lines' of
|
||||
[] -> [ l ]
|
||||
_:lines' -> (l ++ "\n") : actualLines lines')
|
||||
(l, lines') -> case lines' of
|
||||
[] -> [ l ]
|
||||
_:lines' -> (l ++ "\n") : actualLines lines'
|
||||
|
||||
-- | Compute the line ranges within a given range of a string.
|
||||
actualLineRanges :: Range -> String -> [Range]
|
||||
actualLineRanges range = drop 1 . scanl toRange (Range (start range) (start range)) . actualLines . substring range
|
||||
where toRange previous string = Range (end previous) $ end previous + length string
|
||||
|
||||
47
test/ArbitraryTerm.hs
Normal file
47
test/ArbitraryTerm.hs
Normal file
@ -0,0 +1,47 @@
|
||||
module ArbitraryTerm where
|
||||
|
||||
import Categorizable
|
||||
import Syntax
|
||||
import Term
|
||||
import Control.Comonad.Cofree
|
||||
import Control.Monad
|
||||
import qualified OrderedMap as Map
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Set as Set
|
||||
import GHC.Generics
|
||||
import Test.QuickCheck hiding (Fixed)
|
||||
|
||||
newtype ArbitraryTerm a annotation = ArbitraryTerm (annotation, Syntax a (ArbitraryTerm a annotation))
|
||||
deriving (Show, Eq, Generic)
|
||||
|
||||
unTerm :: ArbitraryTerm a annotation -> Term a annotation
|
||||
unTerm = unfold unpack
|
||||
where unpack (ArbitraryTerm (annotation, syntax)) = (annotation, syntax)
|
||||
|
||||
instance (Eq a, Eq annotation, Arbitrary a, Arbitrary annotation) => Arbitrary (ArbitraryTerm a annotation) where
|
||||
arbitrary = 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
|
||||
where boundedTerm maxLength maxDepth = ArbitraryTerm <$> ((,) <$> arbitrary <*> boundedSyntax maxLength maxDepth)
|
||||
boundedSyntax _ maxDepth | maxDepth <= 0 = liftM Leaf arbitrary
|
||||
boundedSyntax maxLength maxDepth = frequency
|
||||
[ (12, liftM Leaf arbitrary),
|
||||
(1, liftM Indexed $ take maxLength <$> listOf (smallerTerm maxLength maxDepth)),
|
||||
(1, liftM Fixed $ take maxLength <$> listOf (smallerTerm maxLength maxDepth)),
|
||||
(1, liftM (Keyed . Map.fromList) $ take maxLength <$> listOf (arbitrary >>= (\x -> (,) x <$> smallerTerm maxLength maxDepth))) ]
|
||||
smallerTerm maxLength maxDepth = boundedTerm (div maxLength 3) (div maxDepth 3)
|
||||
shrink term@(ArbitraryTerm (annotation, syntax)) = (++) (subterms term) $ filter (/= term) $
|
||||
ArbitraryTerm <$> ((,) <$> shrink annotation <*> case syntax of
|
||||
Leaf a -> Leaf <$> shrink a
|
||||
Indexed i -> Indexed <$> (List.subsequences i >>= recursivelyShrink)
|
||||
Fixed f -> Fixed <$> (List.subsequences f >>= recursivelyShrink)
|
||||
Keyed k -> Keyed . Map.fromList <$> (List.subsequences (Map.toList k) >>= recursivelyShrink))
|
||||
|
||||
data CategorySet = A | B | C | D deriving (Eq, Show)
|
||||
|
||||
instance Categorizable CategorySet where
|
||||
categories A = Set.fromList [ "a" ]
|
||||
categories B = Set.fromList [ "b" ]
|
||||
categories C = Set.fromList [ "c" ]
|
||||
categories D = Set.fromList [ "d" ]
|
||||
|
||||
instance Arbitrary CategorySet where
|
||||
arbitrary = elements [ A, B, C, D ]
|
||||
@ -9,164 +9,103 @@ import Test.Hspec.QuickCheck
|
||||
import Test.QuickCheck hiding (Fixed)
|
||||
import Control.Comonad.Cofree
|
||||
import Control.Monad.Free hiding (unfold)
|
||||
import qualified Data.Maybe as Maybe
|
||||
import Line
|
||||
import Row
|
||||
import Patch
|
||||
import Syntax
|
||||
import ArbitraryTerm
|
||||
|
||||
instance Arbitrary Row where
|
||||
instance Arbitrary a => Arbitrary (Row a) where
|
||||
arbitrary = oneof [
|
||||
Row <$> arbitrary <*> arbitrary ]
|
||||
|
||||
instance Arbitrary HTML where
|
||||
instance Arbitrary a => Arbitrary (Line a) where
|
||||
arbitrary = oneof [
|
||||
Text <$> arbitrary,
|
||||
Span <$> arbitrary <*> arbitrary,
|
||||
const Break <$> (arbitrary :: Gen ()) ]
|
||||
|
||||
instance Arbitrary Line where
|
||||
arbitrary = oneof [
|
||||
Line <$> arbitrary <*> arbitrary,
|
||||
Line <$> arbitrary,
|
||||
const EmptyLine <$> (arbitrary :: Gen ()) ]
|
||||
|
||||
arbitraryLeaf :: Gen (String, Info, Syntax String f)
|
||||
arbitraryLeaf = toTuple <$> arbitrary
|
||||
where toTuple string = (string, Info (Range 0 $ length string) mempty, Leaf string)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "annotatedToRows" $ do
|
||||
it "outputs one row for single-line unchanged leaves" $
|
||||
annotatedToRows (unchanged "a" "leaf" (Leaf "")) "a" "a" `shouldBe` ([ Row (Line False [ span "a" ]) (Line False [ span "a" ]) ], (Range 0 1, Range 0 1))
|
||||
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 (Line [ Free $ Annotated info $ Leaf source ]) (Line [ Free $ Annotated info $ Leaf source ]) ]
|
||||
|
||||
it "outputs one row for single-line empty unchanged indexed nodes" $
|
||||
annotatedToRows (unchanged "[]" "branch" (Indexed [])) "[]" "[]" `shouldBe` ([ Row (Line False [ Ul (Just "category-branch") [ Text "[]" ] ]) (Line False [ Ul (Just "category-branch") [ Text "[]" ] ]) ], (Range 0 2, Range 0 2))
|
||||
prop "outputs one row for single-line empty unchanged indexed nodes" $
|
||||
forAll (arbitrary `suchThat` \ s -> filter (/= '\n') s == s) $
|
||||
\ source -> splitAnnotatedByLines (source, source) (totalRange source, totalRange source) (mempty, mempty) (Indexed [] :: Syntax String (Diff String Info)) `shouldBe` [
|
||||
Row (Line [ Free $ Annotated (Info (totalRange source) mempty) $ Indexed [] ]) (Line [ Free $ Annotated (Info (totalRange source) mempty) $ Indexed [] ]) ]
|
||||
|
||||
it "outputs one row for single-line non-empty unchanged indexed nodes" $
|
||||
annotatedToRows (unchanged "[ a, b ]" "branch" (Indexed [
|
||||
Free . offsetAnnotated 2 2 $ unchanged "a" "leaf" (Leaf ""),
|
||||
Free . offsetAnnotated 5 5 $ unchanged "b" "leaf" (Leaf "")
|
||||
])) "[ a, b ]" "[ a, b ]" `shouldBe` ([ Row (Line False [ Ul (Just "category-branch") [ Text "[ ", span "a", Text ", ", span "b", Text " ]" ] ]) (Line False [ Ul (Just "category-branch") [ Text "[ ", span "a", Text ", ", span "b", Text " ]" ] ]) ], (Range 0 8, Range 0 8))
|
||||
prop "preserves line counts in equal sources" $
|
||||
\ source ->
|
||||
length (splitAnnotatedByLines (source, source) (totalRange source, totalRange source) (mempty, mempty) (Indexed . fst $ foldl combineIntoLeaves ([], 0) source)) `shouldBe` length (filter (== '\n') source) + 1
|
||||
|
||||
it "outputs one row for single-line non-empty formatted indexed nodes" $
|
||||
annotatedToRows (formatted "[ a, b ]" "[ a, b ]" "branch" (Indexed [
|
||||
Free . offsetAnnotated 2 2 $ unchanged "a" "leaf" (Leaf ""),
|
||||
Free . offsetAnnotated 5 6 $ unchanged "b" "leaf" (Leaf "")
|
||||
])) "[ a, b ]" "[ a, b ]" `shouldBe` ([ Row (Line False [ Ul (Just "category-branch") [ Text "[ ", span "a", Text ", ", span "b", Text " ]" ] ]) (Line False [ Ul (Just "category-branch") [ Text "[ ", span "a", Text ", ", span "b", Text " ]" ] ]) ], (Range 0 8, Range 0 9))
|
||||
prop "produces the maximum line count in inequal sources" $
|
||||
\ sourceA sourceB ->
|
||||
length (splitAnnotatedByLines (sourceA, sourceB) (totalRange sourceA, totalRange sourceB) (mempty, mempty) (Indexed $ zipWith (leafWithRangesInSources sourceA sourceB) (actualLineRanges (totalRange sourceA) sourceA) (actualLineRanges (totalRange sourceB) sourceB))) `shouldBe` max (length (filter (== '\n') sourceA) + 1) (length (filter (== '\n') sourceB) + 1)
|
||||
|
||||
it "outputs two rows for two-line non-empty unchanged indexed nodes" $
|
||||
annotatedToRows (unchanged "[ a,\nb ]" "branch" (Indexed [
|
||||
Free . offsetAnnotated 2 2 $ unchanged "a" "leaf" (Leaf ""),
|
||||
Free . offsetAnnotated 5 5 $ unchanged "b" "leaf" (Leaf "")
|
||||
])) "[ a,\nb ]" "[ a,\nb ]" `shouldBe`
|
||||
([
|
||||
Row (Line False [ Ul (Just "category-branch") [ Text "[ ", span "a", Text ",", Break ] ])
|
||||
(Line False [ Ul (Just "category-branch") [ Text "[ ", span "a", Text ",", Break] ]),
|
||||
Row (Line False [ Ul (Just "category-branch") [ span "b", Text " ]" ] ])
|
||||
(Line False [ Ul (Just "category-branch") [ span "b", Text " ]" ] ])
|
||||
], (Range 0 8, Range 0 8))
|
||||
|
||||
it "outputs two rows for two-line non-empty formatted indexed nodes" $
|
||||
annotatedToRows (formatted "[ a,\nb ]" "[\na,\nb ]" "branch" (Indexed [
|
||||
Free . offsetAnnotated 2 2 $ unchanged "a" "leaf" (Leaf ""),
|
||||
Free . offsetAnnotated 5 5 $ unchanged "b" "leaf" (Leaf "")
|
||||
])) "[ a,\nb ]" "[\na,\nb ]" `shouldBe`
|
||||
([
|
||||
Row (Line False [ Ul (Just "category-branch") [ Text "[ ", span "a", Text ",", Break ] ])
|
||||
(Line False [ Ul (Just "category-branch") [ Text "[", Break ] ]),
|
||||
Row EmptyLine
|
||||
(Line False [ Ul (Just "category-branch") [ span "a", Text ",", Break ] ]),
|
||||
Row (Line False [ Ul (Just "category-branch") [ span "b", Text " ]" ] ])
|
||||
(Line False [ Ul (Just "category-branch") [ span "b", Text " ]" ] ])
|
||||
], (Range 0 8, Range 0 8))
|
||||
|
||||
it "" $
|
||||
let (sourceA, sourceB) = ("[\na\n,\nb]", "[a,b]") in
|
||||
annotatedToRows (formatted sourceA sourceB "branch" (Indexed [
|
||||
Free . offsetAnnotated 2 1 $ unchanged "a" "leaf" (Leaf ""),
|
||||
Free . offsetAnnotated 6 3 $ unchanged "b" "leaf" (Leaf "")
|
||||
])) sourceA sourceB `shouldBe`
|
||||
([
|
||||
Row (Line False [ Ul (Just "category-branch") [ Text "[", Break ] ])
|
||||
(Line False [ Ul (Just "category-branch") [ Text "[", span "a", Text ",", span "b", Text "]" ] ]),
|
||||
Row (Line False [ Ul (Just "category-branch") [ span "a", Break ] ])
|
||||
EmptyLine,
|
||||
Row (Line False [ Ul (Just "category-branch") [ Text ",", Break ] ])
|
||||
EmptyLine,
|
||||
Row (Line False [ Ul (Just "category-branch") [ span "b", Text "]" ] ])
|
||||
EmptyLine
|
||||
], (Range 0 8, Range 0 5))
|
||||
|
||||
it "should split multi-line deletions across multiple rows" $
|
||||
let (sourceA, sourceB) = ("/*\n*/\na", "a") in
|
||||
annotatedToRows (formatted sourceA sourceB "branch" (Indexed [
|
||||
Pure . Delete $ (Info (Range 0 5) (Set.fromList ["leaf"]) :< (Leaf "")),
|
||||
Free . offsetAnnotated 6 0 $ unchanged "a" "leaf" (Leaf "")
|
||||
])) sourceA sourceB `shouldBe`
|
||||
([
|
||||
Row (Line True [ Ul (Just "category-branch") [ Div (Just "delete") [ span "/*", Break ] ] ]) EmptyLine,
|
||||
Row (Line True [ Ul (Just "category-branch") [ Div (Just "delete") [ span "*/" ], Break ] ]) EmptyLine,
|
||||
Row (Line False [ Ul (Just "category-branch") [ span "a" ] ]) (Line False [ Ul (Just "category-branch") [ span "a" ] ])
|
||||
], (Range 0 7, Range 0 1))
|
||||
|
||||
describe "unicode" $
|
||||
it "equivalent precomposed and decomposed characters are not equal" $
|
||||
let (sourceA, sourceB) = ("t\776", "\7831")
|
||||
syntax = Leaf . Pure $ Replace (info sourceA "leaf" :< (Leaf "")) (info sourceB "leaf" :< (Leaf ""))
|
||||
in
|
||||
annotatedToRows (formatted sourceA sourceB "leaf" syntax) sourceA sourceB `shouldBe`
|
||||
([ Row (Line False [ span "t\776" ]) (Line False [ span "\7831"]) ], (Range 0 2, Range 0 1))
|
||||
|
||||
|
||||
describe "adjoin2" $ do
|
||||
describe "adjoinRowsBy" $ do
|
||||
prop "is identity on top of no rows" $
|
||||
\ a -> adjoin2 [] a == [ a ]
|
||||
\ a -> adjoinRowsBy openMaybe openMaybe [] a == [ a ]
|
||||
|
||||
prop "appends onto open rows" $
|
||||
forAll ((arbitrary `suchThat` isOpen) >>= \ a -> ((,) a) <$> (arbitrary `suchThat` isOpen)) $
|
||||
\ (a@(Row (Line ac1 as1) (Line bc1 bs1)), b@(Row (Line ac2 as2) (Line bc2 bs2))) ->
|
||||
adjoin2 [ a ] b `shouldBe` [ Row (Line (ac1 || ac2) $ as1 ++ as2) (Line (bc1 || bc2) $ bs1 ++ bs2) ]
|
||||
forAll ((arbitrary `suchThat` isOpenBy openMaybe) >>= \ a -> (,) a <$> (arbitrary `suchThat` isOpenBy openMaybe)) $
|
||||
\ (a@(Row (Line a1) (Line b1)), b@(Row (Line a2) (Line b2))) ->
|
||||
adjoinRowsBy openMaybe openMaybe [ a ] b `shouldBe` [ Row (Line $ a1 ++ a2) (Line $ b1 ++ b2) ]
|
||||
|
||||
prop "does not append onto closed rows" $
|
||||
forAll ((arbitrary `suchThat` isClosed) >>= \ a -> ((,) a) <$> (arbitrary `suchThat` isClosed)) $
|
||||
\ (a, b) -> adjoin2 [ a ] b `shouldBe` [ b, a ]
|
||||
forAll ((arbitrary `suchThat` isClosedBy openMaybe) >>= \ a -> (,) a <$> (arbitrary `suchThat` isClosedBy openMaybe)) $
|
||||
\ (a, b) -> adjoinRowsBy openMaybe openMaybe [ a ] b `shouldBe` [ b, a ]
|
||||
|
||||
prop "does not promote elements through empty lines onto closed lines" $
|
||||
forAll ((arbitrary `suchThat` isClosed) >>= \ a -> ((,) a) <$> (arbitrary `suchThat` isClosed)) $
|
||||
\ (a, b) -> adjoin2 [ Row EmptyLine EmptyLine, a ] b `shouldBe` [ b, Row EmptyLine EmptyLine, a ]
|
||||
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 ]
|
||||
|
||||
prop "promotes elements through empty lines onto open lines" $
|
||||
forAll ((arbitrary `suchThat` isOpen) >>= \ a -> ((,) a) <$> (arbitrary `suchThat` isOpen)) $
|
||||
\ (a, b) -> adjoin2 [ Row EmptyLine EmptyLine, a ] b `shouldBe` Row EmptyLine EmptyLine : adjoin2 [ a ] b
|
||||
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
|
||||
|
||||
describe "termToLines" $ do
|
||||
it "splits multi-line terms into multiple lines" $
|
||||
termToLines (Info (Range 0 5) (Set.singleton "leaf") :< (Leaf "")) "/*\n*/"
|
||||
`shouldBe`
|
||||
([
|
||||
Line True [ span "/*", Break ],
|
||||
Line True [ span "*/" ]
|
||||
], Range 0 5)
|
||||
describe "splitTermByLines" $ do
|
||||
prop "preserves line count" $
|
||||
\ source -> let range = totalRange source in
|
||||
splitTermByLines (Info range mempty :< Leaf source) source `shouldBe` (Line . (:[]) . (:< Leaf source) . (`Info` mempty) <$> actualLineRanges range source, range)
|
||||
|
||||
describe "openLine" $ do
|
||||
it "should produce the earliest non-empty line in a list, if open" $
|
||||
openLine [
|
||||
Line True [ Div (Just "delete") [ span "*/" ] ],
|
||||
Line True [ Div (Just "delete") [ span " * Debugging", Break ] ],
|
||||
Line True [ Div (Just "delete") [ span "/*", Break ] ]
|
||||
] `shouldBe` (Just $ Line True [ Div (Just "delete") [ span "*/" ] ])
|
||||
describe "openLineBy" $ do
|
||||
it "produces the earliest non-empty line in a list, if open" $
|
||||
openLineBy (openTerm "\n ") [
|
||||
Line [ Info (Range 1 2) mempty :< Leaf "" ],
|
||||
Line [ Info (Range 0 1) mempty :< Leaf "" ]
|
||||
] `shouldBe` (Just $ Line [ Info (Range 1 2) mempty :< Leaf "" ])
|
||||
|
||||
it "should return Nothing if the earliest non-empty line is closed" $
|
||||
openLine [
|
||||
Line True [ Div (Just "delete") [ span " * Debugging", Break ] ]
|
||||
it "returns Nothing if the earliest non-empty line is closed" $
|
||||
openLineBy (openTerm "\n") [
|
||||
Line [ Info (Range 0 1) mempty :< Leaf "" ]
|
||||
] `shouldBe` Nothing
|
||||
|
||||
describe "openTerm" $ do
|
||||
it "returns Just the term if its substring does not end with a newline" $
|
||||
let term = Info (Range 0 2) mempty :< Leaf "" in openTerm " " term `shouldBe` Just term
|
||||
|
||||
it "returns Nothing for terms whose substring ends with a newline" $
|
||||
openTerm " \n" (Info (Range 0 2) mempty :< Leaf "") `shouldBe` Nothing
|
||||
|
||||
where
|
||||
rightRowText text = rightRow [ Text text ]
|
||||
rightRow xs = Row EmptyLine (Line False xs)
|
||||
leftRowText text = leftRow [ Text text ]
|
||||
leftRow xs = Row (Line False xs) EmptyLine
|
||||
rowText a b = Row (Line False [ Text a ]) (Line False [ Text b ])
|
||||
info source category = Info (totalRange source) (Set.fromList [ category ])
|
||||
unchanged source category = formatted source source category
|
||||
formatted source1 source2 category = Annotated (info source1 category, info source2 category)
|
||||
offsetInfo by (Info (Range start end) categories) = Info (Range (start + by) (end + by)) categories
|
||||
offsetAnnotated by1 by2 (Annotated (left, right) syntax) = Annotated (offsetInfo by1 left, offsetInfo by2 right) syntax
|
||||
span = Span (Just "category-leaf")
|
||||
isOpen (Row a b) = (maybe False (const True) $ openLine [ a ]) && (maybe False (const True) $ openLine [ b ])
|
||||
isClosed (Row a@(Line _ _) b@(Line _ _)) = (maybe True (const False) $ openLine [ a ]) && (maybe True (const False) $ openLine [ b ])
|
||||
isClosed (Row _ _) = False
|
||||
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
|
||||
|
||||
isOnSingleLine (a, _, _) = filter (/= '\n') a == a
|
||||
|
||||
combineIntoLeaves (leaves, start) char = (leaves ++ [ Free $ Annotated (Info (Range start $ start + 1) mempty, Info (Range start $ start + 1) mempty) (Leaf [ char ]) ], start + 1)
|
||||
|
||||
leafWithRangesInSources sourceA sourceB rangeA rangeB = Free $ Annotated (Info rangeA mempty, Info rangeB mempty) (Leaf $ substring rangeA sourceA ++ substring rangeB sourceB)
|
||||
|
||||
openMaybe :: Maybe Bool -> Maybe (Maybe Bool)
|
||||
openMaybe (Just a) = Just (Just a)
|
||||
openMaybe Nothing = Nothing
|
||||
|
||||
@ -5,51 +5,11 @@ import Test.Hspec.QuickCheck
|
||||
import Test.QuickCheck hiding (Fixed)
|
||||
|
||||
import Categorizable
|
||||
import qualified OrderedMap as Map
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Set as Set
|
||||
import Interpreter
|
||||
import Diff
|
||||
import Control.Comonad.Cofree
|
||||
import Control.Monad
|
||||
import GHC.Generics
|
||||
import Syntax
|
||||
import Term
|
||||
|
||||
newtype ArbitraryTerm a annotation = ArbitraryTerm (annotation, (Syntax a (ArbitraryTerm a annotation)))
|
||||
deriving (Show, Eq, Generic)
|
||||
|
||||
unTerm :: ArbitraryTerm a annotation -> Term a annotation
|
||||
unTerm = unfold unpack
|
||||
where unpack (ArbitraryTerm (annotation, syntax)) = (annotation, syntax)
|
||||
|
||||
instance (Eq a, Eq annotation, Arbitrary a, Arbitrary annotation) => Arbitrary (ArbitraryTerm a annotation) where
|
||||
arbitrary = 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
|
||||
where boundedTerm maxLength maxDepth = ArbitraryTerm <$> ((,) <$> arbitrary <*> boundedSyntax maxLength maxDepth)
|
||||
boundedSyntax _ maxDepth | maxDepth <= 0 = liftM Leaf arbitrary
|
||||
boundedSyntax maxLength maxDepth = frequency
|
||||
[ (12, liftM Leaf arbitrary),
|
||||
(1, liftM Indexed $ take maxLength <$> listOf (smallerTerm maxLength maxDepth)),
|
||||
(1, liftM Fixed $ take maxLength <$> listOf (smallerTerm maxLength maxDepth)),
|
||||
(1, liftM (Keyed . Map.fromList) $ take maxLength <$> listOf (arbitrary >>= (\x -> ((,) x) <$> smallerTerm maxLength maxDepth))) ]
|
||||
smallerTerm maxLength maxDepth = boundedTerm (div maxLength 3) (div maxDepth 3)
|
||||
shrink term@(ArbitraryTerm (annotation, syntax)) = (++) (subterms term) $ filter (/= term) $
|
||||
ArbitraryTerm <$> ((,) <$> shrink annotation <*> case syntax of
|
||||
Leaf a -> Leaf <$> shrink a
|
||||
Indexed i -> Indexed <$> (List.subsequences i >>= recursivelyShrink)
|
||||
Fixed f -> Fixed <$> (List.subsequences f >>= recursivelyShrink)
|
||||
Keyed k -> Keyed . Map.fromList <$> (List.subsequences (Map.toList k) >>= recursivelyShrink))
|
||||
|
||||
data CategorySet = A | B | C | D deriving (Eq, Show)
|
||||
|
||||
instance Categorizable CategorySet where
|
||||
categories A = Set.fromList [ "a" ]
|
||||
categories B = Set.fromList [ "b" ]
|
||||
categories C = Set.fromList [ "c" ]
|
||||
categories D = Set.fromList [ "d" ]
|
||||
|
||||
instance Arbitrary CategorySet where
|
||||
arbitrary = elements [ A, B, C, D ]
|
||||
import ArbitraryTerm
|
||||
|
||||
main :: IO ()
|
||||
main = hspec spec
|
||||
|
||||
Loading…
Reference in New Issue
Block a user