Merge branch 'master' into ghc8

semantic-diff.cabal

@@ -32,6 +32,7 @@ library
                      , Language
                      , Language.C
                      , Language.JavaScript
+                     , Language.Markdown
                      , Parser
                      , Patch
                      , Patch.Arbitrary
@@ -58,6 +59,7 @@ library
                      , blaze-html
                      , blaze-markup
                      , bytestring
+                     , cmark
                      , containers
                      , directory
                      , dlist
@@ -113,6 +115,8 @@ test-suite semantic-diff-test
                      , DiffSummarySpec
                      , InterpreterSpec
                      , PatchOutputSpec
+                     , RangeSpec
+                     , Source.Spec
                      , TermSpec
   build-depends:       base
                      , bifunctors

src/Alignment.hs

@@ -24,7 +24,7 @@ import Info
 import Patch
 import Prologue hiding (fst, snd)
 import Range
-import Source hiding (break, fromList, uncons, (++))
+import Source hiding (break, fromList, uncons)
 import SplitDiff
 import Syntax
 import Term

src/Category.hs

@@ -16,8 +16,8 @@ data Category
   | Boolean
   -- | A bitwise operator.
   | BitwiseOperator
-  -- | An operator with 2 operands.
+  -- | A boolean operator (e.g. ||, &&).
-  | BinaryOperator
+  | BooleanOperator
   -- | A literal key-value data structure.
   | DictionaryLiteral
   -- | A pair, e.g. of a key & value
@@ -104,6 +104,8 @@ data Category
   | RelationalOperator
   -- | An empty statement. (e.g. ; in JavaScript)
   | Empty
+  -- | A mathematical operator (e.g. +, -, *, /).
+  | MathOperator
   deriving (Eq, Generic, Ord, Show)
 
 -- Instances
@@ -115,7 +117,8 @@ instance Arbitrary Category where
       pure Program
     , pure Error
     , pure Boolean
-    , pure BinaryOperator
+    , pure BooleanOperator
+    , pure MathOperator
     , pure DictionaryLiteral
     , pure Pair
     , pure FunctionCall

src/DiffSummary.hs

@@ -221,7 +221,8 @@ instance HasCategory Text where
 instance HasCategory Category where
   toCategoryName = \case
     ArrayLiteral -> "array"
-    BinaryOperator -> "binary operator"
+    BooleanOperator -> "boolean operator"
+    MathOperator -> "math operator"
     BitwiseOperator -> "bitwise operator"
     RelationalOperator -> "relational operator"
     Boolean -> "boolean"
@@ -241,7 +242,7 @@ instance HasCategory Category where
     C.Case -> "case statement"
     C.SubscriptAccess -> "subscript access"
     C.MathAssignment -> "math assignment"
-    C.Ternary -> "ternary"
+    C.Ternary -> "ternary expression"
     C.Operator -> "operator"
     Identifier -> "identifier"
     IntegerLiteral -> "integer"

src/Diffing.hs

@@ -2,6 +2,7 @@
 module Diffing where
 
 import Prologue hiding (fst, snd)
+import Category
 import qualified Data.ByteString.Char8 as B1
 import Data.Functor.Both
 import Data.Functor.Foldable
@@ -17,6 +18,7 @@ import Diff
 import Info
 import Interpreter
 import Language
+import Language.Markdown
 import Parser
 import Patch
 import Range
@@ -25,7 +27,7 @@ import Renderer.JSON
 import Renderer.Patch
 import Renderer.Split
 import Renderer.Summary
-import Source hiding ((++))
+import Source
 import Syntax
 import System.Directory
 import System.FilePath
@@ -34,7 +36,6 @@ import Term
 import TreeSitter
 import Text.Parser.TreeSitter.Language
 import qualified Data.Text as T
-import Category
 import Data.Aeson (toJSON, toEncoding)
 import Data.Aeson.Encoding (encodingToLazyByteString)
 
@@ -69,6 +70,7 @@ parserForType :: Text -> Parser (Syntax Text) (Record '[Range, Category])
 parserForType mediaType = case languageForType mediaType of
   Just C -> treeSitterParser C ts_language_c
   Just JavaScript -> treeSitterParser JavaScript ts_language_javascript
+  Just Markdown -> cmarkParser
   Just Ruby -> treeSitterParser Ruby ts_language_ruby
   _ -> lineByLineParser
 

src/Language.hs

@@ -20,6 +20,7 @@ data Language =
     | HTML
     | Java
     | JavaScript
+    | Markdown
     | ObjectiveC
     | Perl
     | PHP
@@ -35,6 +36,7 @@ languageForType mediaType = case mediaType of
     ".h" -> Just C
     ".c" -> Just C
     ".js" -> Just JavaScript
+    ".md" -> Just Markdown
     ".rb" -> Just Ruby
     _ -> Nothing
 

src/Language/JavaScript.hs

@@ -88,8 +88,8 @@ categoryForJavaScriptProductionName name = case name of
   "undefined" -> Identifier
   "arrow_function" -> Function
   "generator_function" -> Function
-  "math_op" -> BinaryOperator -- bitwise operator, e.g. +, -, *, /.
+  "math_op" -> MathOperator -- math operator, e.g. +, -, *, /.
-  "bool_op" -> BinaryOperator -- boolean operator, e.g. ||, &&.
+  "bool_op" -> BooleanOperator -- boolean operator, e.g. ||, &&.
   "comma_op" -> CommaOperator -- comma operator, e.g. expr1, expr2.
   "delete_op" -> Operator -- delete operator, e.g. delete x[2].
   "type_op" -> Operator -- type operator, e.g. typeof Object.

src/Language/Markdown.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE DataKinds #-}
+module Language.Markdown where
+
+import CMark
+import Data.Record
+import Data.Text
+import Info
+import Parser
+import Prologue
+import Range
+import Source
+import SourceSpan
+import Syntax
+
+cmarkParser :: Parser (Syntax Text) (Record '[Range, Category])
+cmarkParser SourceBlob{..} = pure . toTerm (totalRange source) $ commonmarkToNode [ optSourcePos, optSafe ] (toText source)
+  where toTerm :: Range -> Node -> Cofree (Syntax Text) (Record '[Range, Category])
+        toTerm within (Node position t children) = let range = maybe within (sourceSpanToRange source . toSpan) position in cofree $ (range .: toCategory t .: RNil) :< case t of
+          -- Leaves
+          CODE text -> Leaf text
+          TEXT text -> Leaf text
+          CODE_BLOCK _ text -> Leaf text
+          -- Branches
+          _ -> Indexed (toTerm range <$> children)
+
+        toCategory :: NodeType -> Category
+        toCategory (TEXT _) = Other "text"
+        toCategory (CODE _) = Other "code"
+        toCategory (HTML_BLOCK _) = Other "html"
+        toCategory (HTML_INLINE _) = Other "html"
+        toCategory (HEADING _) = Other "heading"
+        toCategory (LIST (ListAttributes{..})) = Other $ case listType of
+          BULLET_LIST -> "unordered list"
+          ORDERED_LIST -> "ordered list"
+        toCategory (LINK{}) = Other "link"
+        toCategory (IMAGE{}) = Other "image"
+        toCategory t = Other (show t)
+        toSpan PosInfo{..} = SourceSpan "" (SourcePos (pred startLine) (pred startColumn)) (SourcePos (pred endLine) endColumn)

src/Renderer.hs

@@ -13,7 +13,7 @@ import Syntax
 -- | A function that will render a diff, given the two source blobs.
 type Renderer annotation = Both SourceBlob -> Diff (Syntax Text) annotation -> Output
 
-data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath, outputPath :: FilePath }
+data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath }
  deriving (Show)
 
 -- | The available types of diff rendering.

src/Renderer/Split.hs

@@ -33,7 +33,8 @@ styleName :: Category -> Text
 styleName category = "category-" <> case category of
   Program -> "program"
   C.Error -> "error"
-  BinaryOperator -> "binary_operator"
+  BooleanOperator -> "boolean_operator"
+  MathOperator -> "math_operator"
   BitwiseOperator -> "bitwise_operator"
   RelationalOperator -> "relational_operator"
   Boolean -> "boolean"

src/Source.hs

@@ -7,6 +7,7 @@ import Data.String
 import qualified Data.Vector as Vector
 import Numeric
 import Range
+import SourceSpan
 
 -- | The source, oid, path, and Maybe SourceKind of a blob in a Git repo.
 data SourceBlob = SourceBlob { source :: Source Char, oid :: String, path :: FilePath, blobKind :: Maybe SourceKind }
@@ -77,24 +78,28 @@ uncons (Source vector) = if null vector then Nothing else Just (Vector.head vect
 break :: (a -> Bool) -> Source a -> (Source a, Source a)
 break predicate (Source vector) = let (start, remainder) = Vector.break predicate vector in (Source start, Source remainder)
 
--- | Concatenate two sources.
-(++) :: Source a -> Source a -> Source a
-(++) (Source a) = Source . (a Vector.++) . getVector
-
 -- | Split the contents of the source after newlines.
 actualLines :: Source Char -> [Source Char]
 actualLines source | null source = [ source ]
 actualLines source = case Source.break (== '\n') source of
   (l, lines') -> case uncons lines' of
     Nothing -> [ l ]
-    Just (_, lines') -> (l Source.++ fromList "\n") : actualLines lines'
+    Just (_, lines') -> (l <> fromList "\n") : actualLines lines'
 
 -- | Compute the line ranges within a given range of a string.
 actualLineRanges :: Range -> Source Char -> [Range]
 actualLineRanges range = drop 1 . scanl toRange (Range (start range) (start range)) . actualLines . slice range
   where toRange previous string = Range (end previous) $ end previous + length string
 
+-- | Compute the character range corresponding to a given SourceSpan within a Source.
+sourceSpanToRange :: Source Char -> SourceSpan -> Range
+sourceSpanToRange source SourceSpan{..} = Range start end
+  where start = sumLengths leadingRanges + column spanStart
+        end = start + sumLengths (take (line spanEnd - line spanStart) remainingRanges) + (column spanEnd - column spanStart)
+        (leadingRanges, remainingRanges) = splitAt (line spanStart) (actualLineRanges (totalRange source) source)
+        sumLengths = sum . fmap (\ Range{..} -> end - start)
+
 
 instance Monoid (Source a) where
   mempty = fromList []
-  mappend = (Source.++)
+  mappend = (Source .) . (Vector.++) `on` getVector

test/RangeSpec.hs

@@ -1,7 +1,8 @@
 module RangeSpec where
 
-import Test.Hspec
+import Prologue
 import Range
+import Test.Hspec
 
 spec :: Spec
 spec = parallel $ do

test/Source/Spec.hs

@@ -0,0 +1,53 @@
+module Source.Spec where
+
+import qualified Prelude
+import Prologue
+import Range
+import Source
+import SourceSpan
+import Test.Hspec
+import Test.Hspec.QuickCheck
+
+spec :: Spec
+spec = parallel $ do
+  describe "actualLineRanges" $ do
+    prop "produces 1 more range than there are newlines" $
+      \ s -> length (actualLineRanges (totalRange s) (fromList s)) `shouldBe` succ (length (filter (== '\n') s))
+
+    prop "produces exhaustive ranges" $
+      \ s -> let source = fromList s in
+        foldMap (`slice` source) (actualLineRanges (totalRange s) source) `shouldBe` source
+
+  describe "sourceSpanToRange" $ do
+    prop "computes single-line ranges" $
+      \ s -> let source = fromList s
+                 spans = zipWith (\ i Range {..} -> SourceSpan "" (SourcePos i 0) (SourcePos i (end - start))) [0..] ranges
+                 ranges = actualLineRanges (totalRange source) source in
+        sourceSpanToRange source <$> spans `shouldBe` ranges
+
+    prop "computes multi-line ranges" $
+      \ s -> let source = fromList s in
+        sourceSpanToRange source (totalSpan source) `shouldBe` totalRange source
+
+    prop "computes sub-line ranges" $
+      \ s -> let source = fromList ('*' : s <> "*") in
+        sourceSpanToRange source (insetSpan (totalSpan source)) `shouldBe` insetRange (totalRange source)
+
+  describe "totalSpan" $ do
+    prop "covers single lines" $
+      \ n -> totalSpan (fromList (replicate n '*')) `shouldBe` SourceSpan "" (SourcePos 0 0) (SourcePos 0 (max 0 n))
+
+    prop "covers multiple lines" $
+      \ n -> totalSpan (fromList (intersperse '\n' (replicate n '*'))) `shouldBe` SourceSpan "" (SourcePos 0 0) (SourcePos (max 0 (pred n)) (if n > 0 then 1 else 0))
+
+totalSpan :: Source Char -> SourceSpan
+totalSpan source = SourceSpan "" (SourcePos 0 0) (SourcePos (pred (length ranges)) (end lastRange - start lastRange))
+  where ranges = actualLineRanges (totalRange source) source
+        lastRange = Prelude.last ranges
+
+insetSpan :: SourceSpan -> SourceSpan
+insetSpan sourceSpan = sourceSpan { spanStart = (spanStart sourceSpan) { column = succ (column (spanStart sourceSpan)) }
+                                  , spanEnd = (spanEnd sourceSpan) { column = pred (column (spanEnd sourceSpan)) } }
+
+insetRange :: Range -> Range
+insetRange Range {..} = Range (succ start) (pred end)

test/Spec.hs

@@ -9,6 +9,8 @@ import qualified Diff.Spec
 import qualified DiffSummarySpec
 import qualified InterpreterSpec
 import qualified PatchOutputSpec
+import qualified RangeSpec
+import qualified Source.Spec
 import qualified TermSpec
 import Test.Hspec
 
@@ -22,4 +24,6 @@ main = hspec . parallel $ do
   describe "DiffSummary" DiffSummarySpec.spec
   describe "Interpreter" InterpreterSpec.spec
   describe "PatchOutput" PatchOutputSpec.spec
+  describe "Range" RangeSpec.spec
+  describe "Source" Source.Spec.spec
   describe "Term" TermSpec.spec