lambdiff-0.1: src/Lambdiff/UI.hs
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 ()