diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Jamie Turner + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jamie Turner nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lambdiff.cabal b/lambdiff.cabal new file mode 100644 --- /dev/null +++ b/lambdiff.cabal @@ -0,0 +1,72 @@ +-- lambdiff.cabal auto-generated by cabal init. For additional +-- options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: lambdiff + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1 + +-- A short (one-line) description of the package. +Synopsis: Diff Viewer + +-- A longer description of the package. +-- Description: + +-- URL for the project homepage or repository. +Homepage: https://github.com/jamwt/lambdiff.git + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Jamie Turner + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: jamie@bu.mp + +-- A copyright notice. +-- Copyright: + +Category: Development + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.4 + +Executable lambdiff + hs-source-dirs: src + + -- Modules not exported by this package. + Other-modules: Lambdiff.DiffParse, + Lambdiff.Process, + Lambdiff.Types, + Lambdiff.UI + + Main-is: Lambdiff/Main.hs + + -- Packages needed in order to build this package. + Build-depends: base >= 4 && < 5, + bytestring>=0.9 && <1.0, + mtl>=2 && <3, + enumerator>=0.4.5 && < 0.5, + attoparsec>=0.9 && <1.0, + gtk>=0.12 && <0.13, + attoparsec-enumerator>=0.2 && < 0.3 + + Extensions: OverloadedStrings,DeriveDataTypeable + Extensions: FlexibleInstances,DoAndIfThenElse,ScopedTypeVariables + Extensions: BangPatterns,GADTs + + Ghc-Options: -O2 -threaded -rtsopts -funfolding-use-threshold=16 -fexcess-precision -feager-blackholing diff --git a/src/Lambdiff/DiffParse.hs b/src/Lambdiff/DiffParse.hs new file mode 100644 --- /dev/null +++ b/src/Lambdiff/DiffParse.hs @@ -0,0 +1,73 @@ +module Lambdiff.DiffParse where + +import Data.ByteString.Char8 as S +import Control.Applicative ((<|>)) + +import qualified Data.Attoparsec as Atto +import qualified Data.Attoparsec.Char8 as AttoC + +data ParseFileResult = ParseFileResult S.ByteString S.ByteString [ParseChunk] + deriving Show + +data ParseChunk = ParseChunk Int Int [ParseLine] + deriving Show + +data ParseLine = ParseLineNone S.ByteString + | ParseLineAdd S.ByteString + | ParseLineSub S.ByteString + | ParseLineComment S.ByteString + deriving Show + +diffParser :: Atto.Parser [ParseFileResult] +diffParser = Atto.many parseDiff + +parseDiff :: Atto.Parser ParseFileResult +parseDiff = do + (f1, f2) <- consumeHeader + chunks <- Atto.many parseChunk + return $ ParseFileResult f1 f2 chunks + +parseChunk :: Atto.Parser ParseChunk +parseChunk = do + Atto.string "@@ -" + lineNo1 <- AttoC.decimal + _ <- Atto.many1 $ AttoC.notChar '+' + _ <- AttoC.char '+' + lineNo2 <- AttoC.decimal + _ <- Atto.many1 $ AttoC.notChar '\n' + _ <- AttoC.char '\n' + lines <- Atto.many1 parseChunkLine + return $ ParseChunk lineNo1 lineNo2 lines + +parseChunkLine :: Atto.Parser ParseLine +parseChunkLine = do + const <- noLead <|> addLead <|> subLead <|> comLead + restOfLine <- AttoC.takeWhile (/='\n') + AttoC.char '\n' + return $ const $ S.concat [restOfLine, "\n"] + +noLead = AttoC.char ' ' >> (return ParseLineNone) +addLead = AttoC.char '+' >> (return ParseLineAdd) +subLead = AttoC.char '-' >> (return ParseLineSub) +comLead = AttoC.char '\\' >> (return ParseLineComment) + +-- | Handle both git-style unified diffs and +-- | diff -u style ones +consumeHeader :: Atto.Parser (S.ByteString, S.ByteString) +consumeHeader = do + (Atto.string "diff " >> AttoC.scan "" findFileTop) <|> (Atto.string "---") + _ <- AttoC.char ' ' + f1 <- AttoC.takeWhile1 (\c -> and [(c/='\n'), (c/='\t')]) + _ <- AttoC.takeWhile (/='\n') + _ <- Atto.string "\n+++ " + f2 <- AttoC.takeWhile1 (\c -> and [(c/='\n'), (c/='\t')]) + _ <- AttoC.takeWhile (/='\n') + _ <- AttoC.char '\n' + return (f1, f2) + where + findFileTop "---\n" ' ' = Nothing + findFileTop _ '\n' = Just "\n" + findFileTop s '-' = Just $ '-' : s + findFileTop _ _ = Just "" + + diff --git a/src/Lambdiff/Main.hs b/src/Lambdiff/Main.hs new file mode 100644 --- /dev/null +++ b/src/Lambdiff/Main.hs @@ -0,0 +1,24 @@ +import Prelude hiding (sequence) +import Control.Monad (when) +import Data.Enumerator (run, ($$), sequence) +import Data.Enumerator.Binary (enumHandle) +import Data.Attoparsec.Enumerator (iterParser) +import System.IO (stdin) +import System.Exit + +import Lambdiff.DiffParse (diffParser) +import Lambdiff.Process (processParseFile) +import Lambdiff.UI (renderUI) + +main = do + res <- run ((enumHandle 262144 stdin) $$ (iterParser diffParser)) + diffs <- case res of + Left _ -> do + putStrLn "Invalid diff; use unified format (`git diff` or `diff -u`)" + exitWith $ ExitFailure 1 + Right d -> return d + when (length diffs == 0) $ do + putStrLn "No renderable diffs in input" + exitWith $ ExitFailure 1 + + renderUI $ map processParseFile diffs diff --git a/src/Lambdiff/Process.hs b/src/Lambdiff/Process.hs new file mode 100644 --- /dev/null +++ b/src/Lambdiff/Process.hs @@ -0,0 +1,85 @@ +module Lambdiff.Process where + +import Data.List (foldl') +import Data.Maybe (fromMaybe) + +import Lambdiff.DiffParse (ParseFileResult(..), + ParseChunk(..), + ParseLine(..)) +import Lambdiff.Types +import Debug.Trace (trace) + +isNotNull = (/= "/dev/null") + +processParseFile :: ParseFileResult -> FileDiff +processParseFile (ParseFileResult name1 name2 chunks) = + FileDiff unifiedFilename direction sections + where + unifiedFilename = if name1exists then name1 else name2 + + name1exists = isNotNull name1 + name2exists = isNotNull name2 + direction = getDirection name1exists name2exists + + getDirection True True = DirectionChanged + getDirection False True = DirectionAdded + getDirection True False = DirectionRemoved + + sections = map processChunk chunks + +processChunk :: ParseChunk -> DiffSection +processChunk (ParseChunk start1 start2 lines) = + DiffSection plines + where + !plines = (reverse . fst4) $! foldl' processLine + ([], start1, start2, Nothing) lines + +fst4 (a, b, c, d) = a + + +processLine :: ([DiffLine], Int, Int, Maybe Int) + -> ParseLine + -> ([DiffLine], Int, Int, Maybe Int) +processLine inp (ParseLineComment s) = inp + +processLine (all, l1, l2, _) (ParseLineNone s) = + (newline : all, l1 + 1, l2 + 1, Nothing) + where + newline = DiffLine DirectionNone (Just (l1, s)) (Just (l2, s)) + +processLine (all, l1, l2, msub) (ParseLineSub s) = + (newline : all, l1 + 1, l2, Just $ (fromMaybe 0 msub) + 1) + where + newline = DiffLine DirectionRemoved (Just (l1, s)) Nothing + + +-- change case, merge: +processLine (all, l1, l2, Just 1) (ParseLineAdd s) = + (fixed, l1, l2 + 1, Nothing) + where + fixed = mergeChange allsimple + allsimple = simple : all + simple = DiffLine DirectionAdded Nothing (Just (l2, s)) + +-- non-change case: +processLine (all, l1, l2, msub) (ParseLineAdd s) = + (newline : all, l1, l2 + 1, fmap (subtract 1) msub) + where + newline = DiffLine DirectionAdded Nothing (Just (l2, s)) + + +mergeChange :: [DiffLine] -> [DiffLine] +mergeChange lines = + mergedLines ++ remainingLines + where + (opLines, remainingLines) = span isAddOrSub lines + + isAddOrSub (DiffLine DirectionAdded _ _) = True + isAddOrSub (DiffLine DirectionRemoved _ _) = True + isAddOrSub _ = False + + mergedLines = uncurry (zipWith mergeLine) $ splitAt (length opLines `div` 2) opLines + + mergeLine (DiffLine DirectionAdded Nothing add) + (DiffLine DirectionRemoved sub Nothing) = + DiffLine DirectionChanged sub add diff --git a/src/Lambdiff/Types.hs b/src/Lambdiff/Types.hs new file mode 100644 --- /dev/null +++ b/src/Lambdiff/Types.hs @@ -0,0 +1,19 @@ +module Lambdiff.Types where + +import Data.ByteString.Char8 as S + +data FileDiff = FileDiff S.ByteString DiffDirection [DiffSection] + deriving Show +data DiffDirection = DirectionAdded + | DirectionRemoved + | DirectionChanged + | DirectionNone + deriving Show + +data DiffSection = DiffSection [DiffLine] + deriving Show + +data DiffLine = DiffLine DiffDirection (Maybe LineData) (Maybe LineData) + deriving Show + +type LineData = (Int, S.ByteString) diff --git a/src/Lambdiff/UI.hs b/src/Lambdiff/UI.hs new file mode 100644 --- /dev/null +++ b/src/Lambdiff/UI.hs @@ -0,0 +1,291 @@ +module Lambdiff.UI where + +import Control.Monad (mapM_) +import System.Exit +import qualified Data.ByteString.Char8 as S +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.Events (Event(Key)) + +import Lambdiff.Types + +renderUI :: [FileDiff] -> IO () +renderUI diffs = do + initGUI + window <- windowNew + outbox <- vBoxNew True 2 + bar <- labelNew $ Just "λiff v0.1 -- use keys (j, k, J, K, l, h, P, N, Esc)" +-- labelSetText bar "lambdiff" +-- entrySetHasFrame bar False +-- set bar [entryEditable := False] + box <- hBoxNew True 8 + boxSetHomogeneous outbox False + boxPackStart outbox box PackGrow 0 + boxPackStart outbox bar PackNatural 0 + tv <- treeViewNew + scrollbox <- scrolledWindowNew Nothing Nothing + ibox <- hBoxNew True 5 + i2 <- textViewNew + i3 <- textViewNew + + textViewSetCursorVisible i2 False + textViewSetCursorVisible i3 False + + scrolledWindowAddWithViewport scrollbox ibox + boxSetHomogeneous box False + boxPackStart box tv PackNatural 0 + boxPackStart box scrollbox PackGrow 0 + + boxPackStart ibox i2 PackGrow 0 + boxPackStart ibox i3 PackGrow 0 + boxSetHomogeneous ibox False + + textViewSetEditable i2 False + textViewSetEditable i3 False + + table <- textTagTableNew + tagMono <- textTagNew $ Just "mono" + tagRemove <- textTagNew $ Just "remove" + tagAdd <- textTagNew $ Just "add" + tagChange <- textTagNew $ Just "change" + tagDull <- textTagNew $ Just "dull" + tagMissing <- textTagNew $ Just "missing" + tagLineNo <- textTagNew $ Just "lineno" + tagSep <- textTagNew $ Just "sep" + + set tagMono [textTagFamily := "monospace", + textTagWeight := 400 + ] + set tagRemove [ textTagParagraphBackground := "#f66" + ] + set tagAdd [ textTagParagraphBackground := "#6f6" + ] + set tagChange [ textTagParagraphBackground := "#ff6" + ] + set tagSep [ textTagParagraphBackground := "#000", + textTagSize := 2500 + ] + set tagDull [ textTagForeground := "#999" + ] + set tagMissing [ textTagParagraphBackground := "#eee" ] + + set tagLineNo [ textTagBackground := "#fff", + textTagForeground := "#999" + ] + + textTagTableAdd table tagMono + textTagTableAdd table tagRemove + textTagTableAdd table tagAdd + textTagTableAdd table tagChange + textTagTableAdd table tagDull + textTagTableAdd table tagMissing + textTagTableAdd table tagLineNo + textTagTableAdd table tagSep + + buf1 <- textBufferNew $ Just table + buf2 <- textBufferNew $ Just table + + list <- listStoreNew diffs + col <- treeViewColumnNew + textRender <- cellRendererTextNew + treeViewColumnPackStart col textRender True + cellLayoutSetAttributes col textRender list $ \row -> [ + cellText := (let FileDiff fn _ _ = row in S.unpack fn) + ] + treeViewSetModel tv list + treeViewAppendColumn tv col + treeViewSetHeadersVisible tv False + + textViewSetBuffer i2 buf1 + textViewSetBuffer i3 buf2 + onCursorChanged tv $ processChange diffs scrollbox tv buf1 buf2 + + set window [containerBorderWidth := 10, + containerChild := outbox ] + onDestroy window mainQuit + onKeyPress window $ handleKeyPress (length diffs) tv scrollbox + widgetShowAll window + + (w, _) <- widgetGetSize tv + let size = min 250 w + widgetSetSizeRequest tv size (-1) + + mainGUI + +pageDown scroll = do + pageMove scroll (+) + +pageUp scroll = do + pageMove scroll (-) + +pageMove scroll op = do + adj <- scrolledWindowGetVAdjustment scroll + here <- adjustmentGetValue adj + pageDown <- adjustmentGetPageIncrement adj + pageSize <- adjustmentGetPageSize adj + upperLimit <- adjustmentGetUpper adj + let halfPage = pageDown / 2.0 + let proposed = here `op` halfPage + let bounded = max 0 $ min (upperLimit - pageSize) proposed + adjustmentSetValue adj bounded + +nextFile = moveFile (+1) +prevFile = moveFile (subtract 1) + +downFiles = moveFile (+10) +upFiles = moveFile (subtract 10) + +moveFile op numItems tv = do + (ix, _) <- treeViewGetCursor tv + case ix of + [] -> return () + (x:[]) -> do + let adj = max 0 $ min (numItems - 1) $ op x + treeViewSetCursor tv [adj] Nothing + _ -> error "unexpected index!" + +shrink = slide (flip subtract) +grow = slide (+) + +slide op tv = do + (w, _) <- widgetGetSize tv + let size = max 0 $ w `op` 30 + widgetSetSizeRequest tv size (-1) + +handleKeyPress numItems tv scroll (Key rel _ _ mods _ _ _ val name char) = do + case name of + "J" -> pageDown scroll + "Page_Down" -> pageDown scroll + "space" -> pageDown scroll + + "K" -> pageUp scroll + "Page_Up" -> pageUp scroll + + "j" -> nextFile numItems tv + "Down" -> nextFile numItems tv + + "k" -> prevFile numItems tv + "Up" -> prevFile numItems tv + + "h" -> shrink tv + "Left" -> shrink tv + "l" -> grow tv + "Right" -> grow tv + + "p" -> upFiles numItems tv + "P" -> upFiles numItems tv + "n" -> downFiles numItems tv + "N" -> downFiles numItems tv + + "Escape" -> exitWith ExitSuccess + o -> (return ()) + return True +-- scrolledWindowSetVAdjustment scroll adj + +processChange :: [FileDiff] -> ScrolledWindow -> TreeView -> TextBuffer -> TextBuffer -> IO () +processChange diffs scroll tv buf1 buf2 = do + (ix, _) <- treeViewGetCursor tv + case ix of + [] -> return () + (x:[]) -> do + let diff = diffs !! x + writeTextForDiff diff scroll buf1 buf2 + _ -> error "unexpected index!" + +clearLastLine buf = do + lines <- textBufferGetLineCount buf + start <- textBufferGetIterAtLineOffset buf (lines - 2) 0 + end <- textBufferGetEndIter buf + textBufferDelete buf start end + +writeTextForDiff :: FileDiff -> ScrolledWindow -> TextBuffer -> TextBuffer -> IO () +writeTextForDiff (FileDiff fn dir secs) scroll buf1 buf2 = do + textBufferSetText buf1 "" + textBufferSetText buf2 "" + adj <- scrolledWindowGetVAdjustment scroll + adjustmentSetValue adj 0 + + mapM_ (\(DiffSection lines)->(mapM_ writeLine $ lines) >> writeSep) secs + + clearLastLine buf1 + start1 <- textBufferGetStartIter buf1 + end1 <- textBufferGetEndIter buf1 + textBufferApplyTagByName buf1 "mono" start1 end1 + + clearLastLine buf2 + start2 <- textBufferGetStartIter buf2 + end2 <- textBufferGetEndIter buf2 + textBufferApplyTagByName buf2 "mono" start2 end2 + + where + lineNum n = concat [replicate (5 - (length s)) ' ', s, " "] + where + s = show n + + writeSep = do + cur <- textBufferGetEndIter buf1 + mark1 <- textBufferCreateMark buf1 Nothing cur True + cur <- textBufferGetEndIter buf2 + mark2 <- textBufferCreateMark buf2 Nothing cur True + textBufferInsertByteStringAtCursor buf1 "\n" + textBufferInsertByteStringAtCursor buf2 "\n" + start1 <- textBufferGetIterAtMark buf1 mark1 + start2 <- textBufferGetIterAtMark buf2 mark2 + {-start1 <- textBufferGetStartIter buf1-} + {-start2 <- textBufferGetStartIter buf2-} + end1 <- textBufferGetEndIter buf1 + end2 <- textBufferGetEndIter buf2 + textBufferApplyTagByName buf1 "sep" start1 end1 + textBufferApplyTagByName buf2 "sep" start2 end2 + + writeLine (DiffLine dir ml1 ml2) = do + cur <- textBufferGetEndIter buf1 + mark1 <- textBufferCreateMark buf1 Nothing cur True + cur <- textBufferGetEndIter buf2 + mark2 <- textBufferCreateMark buf2 Nothing cur True + markMid1 <- case ml1 of + Just (no, bs) -> do + textBufferInsertAtCursor buf1 $ lineNum no + cur <- textBufferGetEndIter buf1 + mark <- textBufferCreateMark buf1 Nothing cur True + textBufferInsertByteStringAtCursor buf1 bs + return $ Just mark + Nothing -> textBufferInsertByteStringAtCursor buf1 "\n" >> (return Nothing) + markMid2 <- case ml2 of + Just (no, bs) -> do + textBufferInsertAtCursor buf2 $ lineNum no + cur <- textBufferGetEndIter buf2 + mark <- textBufferCreateMark buf2 Nothing cur True + textBufferInsertByteStringAtCursor buf2 bs + return $ Just mark + Nothing -> textBufferInsertByteStringAtCursor buf2 "\n" >> (return Nothing) + start1 <- textBufferGetIterAtMark buf1 mark1 + start2 <- textBufferGetIterAtMark buf2 mark2 + {-start1 <- textBufferGetStartIter buf1-} + {-start2 <- textBufferGetStartIter buf2-} + end1 <- textBufferGetEndIter buf1 + end2 <- textBufferGetEndIter buf2 + + case dir of + DirectionAdded -> do + textBufferApplyTagByName buf1 "missing" start1 end1 + textBufferApplyTagByName buf2 "add" start2 end2 + DirectionRemoved -> do + textBufferApplyTagByName buf1 "remove" start1 end1 + textBufferApplyTagByName buf2 "missing" start2 end2 + DirectionChanged -> do + textBufferApplyTagByName buf1 "change" start1 end1 + textBufferApplyTagByName buf2 "change" start2 end2 + DirectionNone -> do + textBufferApplyTagByName buf1 "dull" start1 end1 + textBufferApplyTagByName buf2 "dull" start2 end2 + + case markMid1 of + Just mark -> do + i <- textBufferGetIterAtMark buf1 mark + textBufferApplyTagByName buf1 "lineno" start1 i + Nothing -> return () + case markMid2 of + Just mark -> do + i <- textBufferGetIterAtMark buf2 mark + textBufferApplyTagByName buf2 "lineno" start2 i + Nothing -> return ()