1
1
mirror of https://github.com/github/semantic.git synced 2024-11-28 10:15:55 +03:00

Merge branch 'master' into split-rendering-of-fixed-nodes

# Conflicts:
#	src/Split.hs
This commit is contained in:
Rob Rix 2015-12-11 11:37:20 -05:00
commit aadd8c7f30
4 changed files with 64 additions and 6 deletions

1
.gitignore vendored
View File

@ -6,3 +6,4 @@ xcuserdata
*.xccheckout
.stack-work
libbridge.dylib
semantic-diff-profile.*

View File

@ -1,10 +1,20 @@
table {
width: 100%;
width: 100%;
table-layout: fixed;
}
table.diff td {
width: 50%;
height: 15px;
}
table.diff td.blob-num {
width: 40px;
}
table.diff td.blob-code {
min-width: 100px;
}
#before, #after {
width: 50%;
}

View File

@ -53,6 +53,25 @@ executable semantic-diff-exe
extra-libraries: bridge
extra-lib-dirs: .
executable semantic-diff-profile
hs-source-dirs: app
main-is: Main.hs
other-modules: TreeSitter
ghc-options: -O2
-threaded
-fprof-auto
"-with-rtsopts=-N -p -s -h -i0.1"
build-depends: base
, containers
, free
, semantic-diff
, bytestring
, optparse-applicative
, filepath
default-language: Haskell2010
extra-libraries: bridge
extra-lib-dirs: .
test-suite semantic-diff-test
type: exitcode-stdio-1.0
hs-source-dirs: test

View File

@ -10,6 +10,7 @@ import Control.Comonad.Cofree
import Range
import Control.Monad.Free
import Data.ByteString.Lazy.Internal
import Text.Blaze.Html
import Text.Blaze.Html5 hiding (map)
import qualified Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Utf8
@ -61,7 +62,20 @@ split diff before after = return . renderHtml
. ((head $ link ! A.rel (stringValue "stylesheet") ! A.href (stringValue "style.css")) <>)
. body
. (table ! A.class_ (stringValue "diff"))
. mconcat $ toMarkup <$> (fst $ diffToRows diff (0, 0) before after)
. mconcat $ toMarkup <$> (reverse $ foldl numberRows [] rows)
where
rows = fst $ diffToRows diff (0, 0) before after
numberRows :: [(Int, Line, Int, Line)] -> Row -> [(Int, Line, Int, Line)]
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 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 right) = (leftCount + 1, left, rightCount + 1, right):rows
data Row = Row Line Line
deriving Eq
@ -69,12 +83,26 @@ data Row = Row Line Line
instance Show Row where
show (Row left right) = "\n" ++ show left ++ " | " ++ show right
instance ToMarkup Row where
toMarkup (Row left right) = (tr $ toMarkup left <> toMarkup right) <> string "\n"
instance ToMarkup (Int, Line, Int, Line) where
toMarkup (_, EmptyLine, _, EmptyLine) = tr $ numberTd "" <> td (string "") <> numberTd "" <> toMarkup (string "") <> string "\n"
toMarkup (_, EmptyLine, num, right) = tr $ numberTd "" <> td (string "") <>
numberTd (show num) <> toMarkup right <> string "\n"
toMarkup (num, left, _, EmptyLine) = tr $ numberTd (show num) <> toMarkup left <>
numberTd "" <> td (string "") <> string "\n"
toMarkup (leftNum, left, rightNum, right) = tr $ numberTd (show leftNum) <> toMarkup left <>
numberTd (show rightNum) <> toMarkup right <> string "\n"
numberTd :: String -> Html
numberTd s = td (string s) ! A.class_ (stringValue "blob-num")
codeTd :: Html -> Html
codeTd el = td el ! A.class_ (stringValue "blob-code")
--instance ToMarkup Row where
-- toMarkup (Row left right) = (tr $ toMarkup left <> toMarkup right) <> string "\n"
instance ToMarkup Line where
toMarkup EmptyLine = td (string "")
toMarkup (Line html) = td . mconcat $ toMarkup <$> html
toMarkup EmptyLine = codeTd (string "")
toMarkup (Line html) = codeTd . mconcat $ toMarkup <$> html
data Line =
Line [HTML]