Merge pull request #357 from github/split-refactoring

Split refactoring

UI/style.css

@@ -81,12 +81,14 @@ body {
   padding: 0;
   font-family: monospace;
 }
-.blob-code-replacement:last-child .insert,
+.blob-code:last-child .patch,
-.blob-code-replacement:last-child .replace {
+.blob-code:last-child .insert,
+.blob-code:last-child .replace {
   background-color: #a6f3a6;
 }
-.blob-code-replacement .delete,
+.blob-code .patch,
-.blob-code-replacement .replace {
+.blob-code .delete,
+.blob-code .replace {
   background-color: #f8cbcb;
 }
 

semantic-diff.cabal

@@ -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

src/Line.hs

@@ -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"

src/OrderedMap.hs

@@ -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
+map ! key = Maybe.fromMaybe (error "no value found for key") $ OrderedMap.lookup key map
-  Just value -> value
-  Nothing -> error "no value found for key"
 
 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

src/Range.hs

@@ -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

src/Row.hs

@@ -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

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 =
+classifyMarkup :: Foldable f => f String -> Markup -> Markup
-  Break
+classifyMarkup categories element = maybe element ((element !) . A.class_ . stringValue . ("category-" ++)) $ maybeLast categories
-  | 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
 
 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))
+        ((colgroup $ (col ! A.width (stringValue . show $ columnWidth)) <> col <> (col ! A.width (stringValue . show $ columnWidth)) <> col) <>)
-        . mconcat $ toMarkup <$> reverse numbered
+        . 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 left@(Line _) EmptyLine) = [(1, left, 0, EmptyLine)]
-    numberRows [] (Row EmptyLine right@(Line _ _)) = [(0, EmptyLine, 1, right)]
+    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 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 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
+newtype Renderable a = Renderable (String, a)
-  deriving Eq
 
-instance Show Row where
+instance ToMarkup f => ToMarkup (Renderable (Info, Syntax a (f, Range))) where
-  show (Row left right) = "\n" ++ show left ++ " | " ++ show right
+  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
+          contentElements children = let (elements, previous) = foldl markupForSeparatorAndChild ([], start range) children in
-  toMarkup (m, left, n, right) = tr $ toMarkup (m, left) <> toMarkup (n, right) <> string "\n"
+            elements ++ [ string $ substring (Range previous $ end range) source ]
 
-instance ToMarkup (Int, Line) where
+instance ToMarkup (Renderable (Term a Info)) where
-  toMarkup (_, EmptyLine) = numberTd "" <> toMarkup EmptyLine <> string "\n"
+  toMarkup (Renderable (source, term)) = fst $ cata (\ info@(Info range _) syntax -> (toMarkup $ Renderable (source, (info, syntax)), range)) term
-  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"
 
-numberTd :: String -> Html
+instance ToMarkup (Renderable (SplitDiff a Info)) where
-numberTd "" = td mempty ! A.class_ (stringValue "blob-num blob-num-empty empty-cell")
+  toMarkup (Renderable (source, diff)) = fst $ iter (\ (Annotated info@(Info range _) syntax) -> (toMarkup $ Renderable (source, (info, syntax)), range)) $ toMarkupAndRange <$> diff
-numberTd s = td (string s) ! A.class_ (stringValue "blob-num")
+    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
+splitDiffByLines :: Diff a Info -> (Int, Int) -> (String, String) -> ([Row (SplitDiff a Info)], (Range, Range))
-codeTd _ Nothing = td mempty ! A.class_ (stringValue "blob-code blob-code-empty empty-cell")
+splitDiffByLines diff (prevLeft, prevRight) sources = case diff of
-codeTd True (Just el) = td el ! A.class_ (stringValue "blob-code blob-code-replacement")
+  Free (Annotated annotation syntax) -> (splitAnnotatedByLines sources (ranges annotation) (categories annotation) syntax, ranges annotation)
-codeTd _ (Just el) = td el ! A.class_ (stringValue "blob-code")
+  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
+-- | Takes a term and a source and returns a list of lines and their range within source.
-  toMarkup EmptyLine = codeTd False Nothing
+splitTermByLines :: Term a Info -> String -> ([Line (Term a Info)], Range)
-  toMarkup (Line changed html) = codeTd changed . Just . mconcat $ toMarkup <$> html
+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 =
+        childLines constructor (lines, previous) child = let (childLines, childRange) = splitTermByLines child source in
-  Line Bool [HTML]
+          (adjoin $ lines ++ contextLines (:< constructor) (Range previous $ start childRange) categories source ++ childLines, end childRange)
-  | EmptyLine
-  deriving Eq
 
-unLine :: Line -> [HTML]
+splitAnnotatedByLines :: (String, String) -> (Range, Range) -> (Set.Set Category, Set.Set Category) -> Syntax a (Diff a Info) -> [Row (SplitDiff a Info)]
-unLine EmptyLine = []
+splitAnnotatedByLines sources ranges categories syntax = case syntax of
-unLine (Line _ htmls) = htmls
+  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
+        adjoin = reverse . foldl (adjoinRowsBy (openDiff $ fst sources) (openDiff $ snd sources)) []
-isChanged EmptyLine = False
+        adjoinChildRows constructor children = let (rows, previous) = foldl (childRows $ constructor mempty) ([], starts ranges) children in
-isChanged (Line isChanged _) = isChanged
+          adjoin $ rows ++ contextRows (constructor mempty) (makeRanges previous (ends ranges)) categories sources
 
-instance Show Line where
+        childRows constructor (rows, previous) child = let (childRows, childRanges) = splitDiffByLines child previous sources in
-  show (Line change elements) = show change ++ " [" ++ (concat . intersperse ", " $ show <$> elements) ++ "]"
+          (adjoin $ rows ++ contextRows constructor (makeRanges previous (starts childRanges)) categories sources ++ childRows, ends childRanges)
-  show EmptyLine = "EmptyLine"
 
-instance Monoid Line where
+        starts (left, right) = (start left, start right)
- mempty = EmptyLine
+        ends (left, right) = (end left, end right)
- mappend EmptyLine EmptyLine = EmptyLine
+        makeRanges (leftStart, rightStart) (leftEnd, rightEnd) = (Range leftStart leftEnd, Range rightStart rightEnd)
- 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)
 
-instance Monoid Row where
+contextLines :: (Info -> a) -> Range -> Set.Set Category -> String -> [Line a]
-  mempty = Row EmptyLine EmptyLine
+contextLines constructor range categories source = Line . (:[]) . constructor . (`Info` categories) <$> actualLineRanges range source
-  mappend (Row x1 y1) (Row x2 y2) = Row (x1 <> x2) (y1 <> y2)
 
-diffToRows :: Diff a Info -> (Int, Int) -> String -> String -> ([Row], (Range, Range))
+openRange :: String -> Range -> Maybe Range
-diffToRows (Free annotated) _ before after = annotatedToRows annotated before after
+openRange source range = case (source !!) <$> maybeLastIndex range of
-diffToRows (Pure (Insert term)) (previousIndex, _) _ after = (rowWithInsertedLine <$> afterLines, (Range previousIndex previousIndex, range))
+  Just '\n' -> Nothing
-  where
+  _ -> Just range
-    (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
 
--- | Takes a term and a `source` and returns a list of HTML lines
+openTerm :: String -> Term a Info -> Maybe (Term a Info)
--- | and their range within `source`.
+openTerm source term@(Info range _ :< _) = const term <$> openRange source range
-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
 
-    rewrapLineContentsIn f (Line _ elements) = Line True [ f (classify categories) elements ]
+openDiff :: String -> SplitDiff a Info -> Maybe (SplitDiff a Info)
-    rewrapLineContentsIn _ EmptyLine = EmptyLine
+openDiff source diff@(Free (Annotated (Info range _) _)) = const diff <$> openRange source range
-    lineElements r s = Line True . (:[]) <$> textElements r s
+openDiff source diff@(Pure term) = const diff <$> openTerm source term
-    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)
 
--- | Given an Annotated and before/after strings, returns a list of `Row`s representing the newline-separated diff.
+zipWithDefaults :: (a -> b -> c) -> a -> b -> [a] -> [b] -> [c]
-annotatedToRows :: Annotated a (Info, Info) (Diff a Info) -> String -> String -> ([Row], (Range, Range))
+zipWithDefaults f da db a b = take (max (length a) (length b)) $ zipWith f (a ++ repeat da) (b ++ repeat db)
-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
 
 actualLines :: String -> [String]
 actualLines "" = [""]
 actualLines lines = case break (== '\n') lines of
-  (l, lines') -> (case lines' of
+  (l, lines') -> case lines' of
-                       [] -> [ l ]
+                      [] -> [ l ]
-                       _:lines' -> (l ++ "\n") : actualLines lines')
+                      _: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

test/ArbitraryTerm.hs

@@ -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 ]

test/SplitSpec.hs

@@ -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,
+    Line <$> arbitrary,
-    Span <$> arbitrary <*> arbitrary,
-    const Break <$> (arbitrary :: Gen ()) ]
-
-instance Arbitrary Line where
-  arbitrary = oneof [
-    Line <$> arbitrary <*> 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
+  describe "splitAnnotatedByLines" $ do
-    it "outputs one row for single-line unchanged leaves" $
+    prop "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))
+      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" $
+    prop "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))
+      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" $
+    prop "preserves line counts in equal sources" $
-      annotatedToRows (unchanged "[ a, b ]" "branch" (Indexed [
+      \ source ->
-        Free . offsetAnnotated 2 2 $ unchanged "a" "leaf" (Leaf ""),
+        length (splitAnnotatedByLines (source, source) (totalRange source, totalRange source) (mempty, mempty) (Indexed . fst $ foldl combineIntoLeaves ([], 0) source)) `shouldBe` length (filter (== '\n') source) + 1
-        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))
 
-    it "outputs one row for single-line non-empty formatted indexed nodes" $
+    prop "produces the maximum line count in inequal sources" $
-      annotatedToRows (formatted "[ a, b ]" "[ a,  b ]" "branch" (Indexed [
+      \ sourceA sourceB ->
-        Free . offsetAnnotated 2 2 $ unchanged "a" "leaf" (Leaf ""),
+        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)
-        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))
 
-    it "outputs two rows for two-line non-empty unchanged indexed nodes" $
+  describe "adjoinRowsBy" $ do
-      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
     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)) $
+      forAll ((arbitrary `suchThat` isOpenBy openMaybe) >>= \ a -> (,) a <$> (arbitrary `suchThat` isOpenBy openMaybe)) $
-        \ (a@(Row (Line ac1 as1) (Line bc1 bs1)), b@(Row (Line ac2 as2) (Line bc2 bs2))) ->
+        \ (a@(Row (Line a1) (Line b1)), b@(Row (Line a2) (Line b2))) ->
-          adjoin2 [ a ] b `shouldBe` [ Row (Line (ac1 || ac2) $ as1 ++ as2) (Line (bc1 || bc2) $ bs1 ++ bs2) ]
+          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)) $
+      forAll ((arbitrary `suchThat` isClosedBy openMaybe) >>= \ a -> (,) a <$> (arbitrary `suchThat` isClosedBy openMaybe)) $
-        \ (a, b) -> adjoin2 [ a ] b `shouldBe` [ b, a ]
+        \ (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)) $
+      forAll ((arbitrary `suchThat` isClosedBy openMaybe) >>= \ a -> (,) a <$> (arbitrary `suchThat` isClosedBy openMaybe)) $
-        \ (a, b) -> adjoin2 [ Row EmptyLine EmptyLine, a ] b `shouldBe` [ b, Row EmptyLine EmptyLine, a ]
+        \ (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)) $
+      forAll ((arbitrary `suchThat` isOpenBy openMaybe) >>= \ a -> (,) a <$> (arbitrary `suchThat` isOpenBy openMaybe)) $
-        \ (a, b) -> adjoin2 [ Row EmptyLine EmptyLine, a ] b `shouldBe` Row EmptyLine EmptyLine : adjoin2 [ a ] b
+        \ (a, b) -> adjoinRowsBy openMaybe openMaybe [ Row EmptyLine EmptyLine, a ] b `shouldBe` Row EmptyLine EmptyLine : adjoinRowsBy openMaybe openMaybe [ a ] b
 
-  describe "termToLines" $ do
+  describe "splitTermByLines" $ do
-    it "splits multi-line terms into multiple lines" $
+    prop "preserves line count" $
-      termToLines (Info (Range 0 5) (Set.singleton "leaf") :< (Leaf "")) "/*\n*/"
+      \ source -> let range = totalRange source in
-      `shouldBe`
+        splitTermByLines (Info range mempty :< Leaf source) source `shouldBe` (Line . (:[]) . (:< Leaf source) . (`Info` mempty) <$> actualLineRanges range source, range)
-      ([
-        Line True [ span "/*", Break ],
-        Line True [ span "*/" ]
-      ], Range 0 5)
 
-  describe "openLine" $ do
+  describe "openLineBy" $ do
-    it "should produce the earliest non-empty line in a list, if open" $
+    it "produces the earliest non-empty line in a list, if open" $
-      openLine [
+      openLineBy (openTerm "\n ") [
-        Line True [ Div (Just "delete") [ span "*/" ] ],
+        Line [ Info (Range 1 2) mempty :< Leaf "" ],
-        Line True [ Div (Just "delete") [ span " * Debugging", Break ] ],
+        Line [ Info (Range 0 1) mempty :< Leaf "" ]
-        Line True [ Div (Just "delete") [ span "/*", Break ] ]
+      ] `shouldBe` (Just $ Line [ Info (Range 1 2) mempty :< Leaf "" ])
-      ] `shouldBe` (Just $ Line True [ Div (Just "delete") [ span "*/" ] ])
 
-    it "should return Nothing if the earliest non-empty line is closed" $
+    it "returns Nothing if the earliest non-empty line is closed" $
-      openLine [
+      openLineBy (openTerm "\n") [
-        Line True [ Div (Just "delete") [ span " * Debugging", Break ] ]
+        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 ]
+      isOpenBy f (Row a b) = Maybe.isJust (openLineBy f [ a ]) && Maybe.isJust (openLineBy f [ b ])
-      rightRow xs = Row EmptyLine (Line False xs)
+      isClosedBy f (Row a@(Line _) b@(Line _)) = Maybe.isNothing (openLineBy f [ a ]) && Maybe.isNothing (openLineBy f [ b ])
-      leftRowText text = leftRow [ Text text ]
+      isClosedBy _ (Row _ _) = False
-      leftRow xs = Row (Line False xs) EmptyLine
+
-      rowText a b = Row (Line False [ Text a ]) (Line False [ Text b ])
+      isOnSingleLine (a, _, _) = filter (/= '\n') a == a
-      info source category = Info (totalRange source)  (Set.fromList [ category ])
+
-      unchanged source category = formatted source source category
+      combineIntoLeaves (leaves, start) char = (leaves ++ [ Free $ Annotated (Info (Range start $ start + 1) mempty, Info (Range start $ start + 1) mempty) (Leaf [ char ]) ], start + 1)
-      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
+      leafWithRangesInSources sourceA sourceB rangeA rangeB = Free $ Annotated (Info rangeA mempty, Info rangeB mempty) (Leaf $ substring rangeA sourceA ++ substring rangeB sourceB)
-      offsetAnnotated by1 by2 (Annotated (left, right) syntax) = Annotated (offsetInfo by1 left, offsetInfo by2 right) syntax
+
-      span = Span (Just "category-leaf")
+      openMaybe :: Maybe Bool -> Maybe (Maybe Bool)
-      isOpen (Row a b) = (maybe False (const True) $ openLine [ a ]) && (maybe False (const True) $ openLine [ b ])
+      openMaybe (Just a) = Just (Just a)
-      isClosed (Row a@(Line _ _) b@(Line _ _)) = (maybe True (const False) $ openLine [ a ]) && (maybe True (const False) $ openLine [ b ])
+      openMaybe Nothing =  Nothing
-      isClosed (Row _ _) = False

test/TermSpec.hs

@@ -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
-
+import ArbitraryTerm
-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 ]
 
 main :: IO ()
 main = hspec spec