diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/WXDiffCtrl.cabal b/WXDiffCtrl.cabal new file mode 100644 --- /dev/null +++ b/WXDiffCtrl.cabal @@ -0,0 +1,34 @@ +Name: WXDiffCtrl +Version: 0.0.1 +License: BSD3 +License-file: license.txt +Homepage: http://wewantarock.wordpress.com +Author: Jeremy O'Donoghue +Build-Type: Simple +Category: GUI, User interfaces +Cabal-Version: >= 1.6 +Description: A very simple diff control, written as an example of how to create a + custom control in wxHaskell. +Maintainer: jeremy.odonoghue@gmail.com +Synopsis: WXDiffCtrl +Data-Files: WXDiffCtrl.cabal + +Flag splitBase + Description: Choose the new smaller, split-up base package. + +Library + if flag(splitBase) + build-depends: base >= 3 && < 5, + wx > 0.12.1.2, + wxcore >= 0.12.1.2, + containers >= 0.2.0.1 + else + build-depends: base < 3, + wx > 0.12.1.2, + wxcore >= 0.12.1.2 + + Exposed-Modules: + Graphics.UI.WXContrib.WXDiffCtrl + Graphics.UI.WXContrib.WXFontMetrics + + Hs-Source-Dirs: src diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,27 @@ + Copyright (C) Jeremy O'Donoghue (jeremy.odonoghue@gmail.com) 2008-2010. + 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. + + The name of Jeremy O'Donoghue may not 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 HOLDER 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/src/Graphics/UI/WXContrib/WXDiffCtrl.lhs b/src/Graphics/UI/WXContrib/WXDiffCtrl.lhs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WXContrib/WXDiffCtrl.lhs @@ -0,0 +1,761 @@ +> {-# LANGUAGE TypeSynonymInstances #-} + + Copyright (C) Jeremy O'Donoghue (jeremy.odonoghue@gmail.com) 2008-2010. + 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. + + The name of Jeremy O'Donoghue may not 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 HOLDER 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 controls + +A simple diff control designed to show differences between two files. + +The control consists of the following components: + +/----------------------- panel -----------------------\ +| /-- static text --\ /-- static text --\ | +| \-----------------/ \-----------------/ | +| /- window ------------\ /- window ------------\ /-\ | +| | | | | | | | +| | | | | | | | +| | | | | | | | +| \---------------------/ \---------------------/ \-/ | +| /-------------------------------------------------\ | +| | scroll bar | | +| \-------------------------------------------------/ | +\-----------------------------------------------------/ + +The diff text will be displayed in the panel areas, based on the output +of a unified diff command (e.g. p4 diff2 -u) +This generates output similar to the following (which has been cut down for +clarity - it is therefore not accurate output) + +--- //depot/asic/sandbox/projects/WM7_rework/sources.inc 2009/04/23 19:29:40 ++++ //depot/asic/sandbox/projects/VIRTIO_8650_APPS_2107/sources.inc 2009/07/09 06:55:53 +@@ -120,12 +120,33 @@ + WINCEOEM=1 + WINCECPU=1 + NOMIPS16CODE=1 +-WARNISERROR=1 ++!if "$(T_VIRTIO)" == "1" ++WARNISERROR= ++!else ++WARNISERROR= ++!endif + DEPRECATE_UNSAFE_CRT=1 + +@@ -207,6 +228,13 @@ + CDEFINES = $(CDEFINES) -Duldr + !endif + ++!if "$(BSP_PANEL_MOUSE)" == "1" ++CDEFINES = $(CDEFINES) -DFEATURE_PANEL_MOUSE ++!endif ++ ++!if "$(BSP_ROTATOR)" == "1" ++CDEFINES = $(CDEFINES) -DFEATURE_ROTATOR ++!endif + +Observations: + ++++ and --- identify the files being compared +- indicates line deleted from sandbox which is present in source ++ indicates line added to source and not present in sandbox +@@ -n1,m1 +n2,m2 @@ at line n1 in source, change m1 lines, at line n2 in sandbox, change m2 lines + +In the implementation, we show all lines prefixed with '+' in the right hand text box with +a corresponding (maybe grey) blank line in the left hand box. + +Similarly, all lines prefixed with '-' are displayed in the left hand text box with a +corresponding blank line in the right hand box. + +Lines with no prefix are shown on both sides, of course. + +Whenever we get a @@, we show an indication of the new position in each of the two files. + +In the case where a file is added or is not present in the source location, we show nothing at +all. + +================================================================================ + +> module Graphics.UI.WXContrib.WXDiffCtrl +> ( diffViewer +> , DiffViewer +> , diffFiles +> , diffFn +> , font +> , fontSize +> , fontWeight +> , fontFamily +> , fontShape +> , fontFace +> , fontUnderline +> , textBgcolor +> , textColor +> ) +> where +> +> import Control.Monad (liftM) +> import Data.Bits ((.|.)) +> import qualified Data.Map as Map +> import qualified Data.HashTable as Hash +> import Data.List (replicate, foldl') +> import Data.Maybe (fromJust) +> import Foreign.Ptr (nullPtr) +> import Graphics.UI.WX +> import Graphics.UI.WXCore +> import System.IO.Unsafe (unsafePerformIO) + +> import Graphics.UI.WXContrib.WXFontMetrics + +Define diffViewer as a subclass of Window. CDiffViewer is used as a witness type +to assist in type safe casting. + +> type DiffViewer a = Panel (CDiffViewer a) +> data CDiffViewer a = CDiffViewer + +Create an instance of a diffViewer control. In this case we create a panel as a child +of the provided parent window. + +> diffViewer :: Window a -> [Prop (DiffViewer ())] -> IO (DiffViewer ()) +> diffViewer parent props = +> do +> p <- panel parent [style := wxEXPAND] +> let dv = cast p +> dvprops = castProps cast props +> diffViewer' dv dvprops +> where +> cast :: Panel a -> DiffViewer () +> cast = objectCast + +The common control creation function. This creates the control inside a provided panel. + +> diffViewer' p props = +> do +> fn1 <- staticText p [clientSize := sz 400 (-1)] +> fn2 <- staticText p [clientSize := sz 400 (-1)] +> f1 <- window p [] +> f2 <- window p [] +> vsb <- scrollBarCreate p (-1) rectNull wxVERTICAL +> hsb <- scrollBarCreate p (-1) rectNull wxHORIZONTAL +> set f1 [ on paint := onPaint p DVorig f1 ] +> set f2 [ on paint := onPaint p DVchanged f2 ] +> let state = DVS p fn1 fn2 f1 f2 vsb hsb Nothing dvf_default Map.empty +> defaults = [border := BorderStatic] +> scrollBarSetEventHandler hsb (onScroll p hsb) +> scrollBarSetEventHandler vsb (onScroll p vsb) +> dvSetState p state +> set p (defaults ++ props) +> buildLayout p fn1 fn2 f1 f2 vsb hsb +> return p + +The wxHaskell layout implementation is buggy in some circumstances (doesn't handle +resizes as I would expect when window size exceeds minsize). Therefore, we create +layout by hand. + +> buildLayout p fn1 fn2 f1 f2 vsb hsb = +> boxSizerCreate wxVERTICAL >>= \p_sizer -> +> boxSizerCreate wxHORIZONTAL >>= \h_sizer -> +> boxSizerCreate wxVERTICAL >>= \l_sizer -> +> boxSizerCreate wxVERTICAL >>= \r_sizer -> +> sizerAddWindow l_sizer fn1 0 (wxALL .|. wxEXPAND) 5 nullPtr >> +> sizerAddWindow l_sizer f1 1 wxEXPAND 10 nullPtr >> +> sizerAddSizer h_sizer l_sizer 1 wxEXPAND 5 nullPtr >> +> sizerAddWindow r_sizer fn2 0 (wxALL .|. wxEXPAND) 5 nullPtr >> +> sizerAddWindow r_sizer f2 1 wxEXPAND 10 nullPtr >> +> sizerAddSizer h_sizer r_sizer 1 wxEXPAND 5 nullPtr >> +> sizerAddWindow h_sizer vsb 0 (wxALL .|. wxEXPAND) 5 nullPtr >> +> sizerAddSizer p_sizer h_sizer 1 wxEXPAND 5 nullPtr >> +> sizerAddWindow p_sizer hsb 0 (wxALL .|. wxEXPAND) 5 nullPtr >> +> windowSetSizer p p_sizer >> +> windowLayout p >> +> windowFit p + +Connect event handlers for scroll bars. These require special handling because: + + a) wxHaskell does not have much special handling for ScrollBar instances which + are not owned/controlled automatically by parent windows. + 2) The required behaviour is pretty special anyway! + +Here we configure an event handler for all scroll events + +> scrollBarSetEventHandler window evtHandler = +> windowOnEvent window events evtHandler (\evt -> evtHandler) +> where +> events = [ wxEVT_SCROLL_BOTTOM +> , wxEVT_SCROLL_LINEDOWN +> , wxEVT_SCROLL_LINEUP +> , wxEVT_SCROLL_PAGEDOWN +> , wxEVT_SCROLL_PAGEUP +> , wxEVT_SCROLL_THUMBRELEASE +> , wxEVT_SCROLL_THUMBTRACK +> , wxEVT_SCROLL_TOP ] + +We respond to all scroll events. There is no difference in behaviour between +the horizontal and vertical scroll bars - we just cause window to refresh on +each event. + +> onScroll dv _ = +> windowRefresh dv True + +================================================================================ + +Execute diff command + +Execute the diff function and populate the map containing the diff strings, +updating the state after execution and performing a display update. + +There is an underlying assumption that the filenames of the two files on +which diff function will execute have been set. This is most easily guaranteed +by calling 'runDiff' via 'whenDifflegal' + +Diff text is stored as a Map, keyed on line number. Maps offer an efficient +mechanism for access to data, and should perform well even for large data sets +(O(log n) insert, O(n) to fetch all keys, O(log n) lookup). Once created, the +map is updated in the control global state. + +The window is refreshed here as the existing contents will clearly +be invalidated by the diff operation. + +> runDiff win diff_fn orig update st = +> diff_fn orig update >>= \strings -> +> let map = Map.empty +> diffs = parseDiffLines strings +> map' = foldl' (\m (v, k) -> Map.insert k v m) map $ zip diffs [0..] +> st' = st { dvs_txt = map' } in +> dvSetState win st' >> +> setVirtualCanvas win >> +> windowRefresh win True + +There are two cases in which it is legitimate to execute the diff function: + + a) The files to be diffed change. In this case, runDiff is called from + dvSetFiles, if and only if a diff function is also configured. + + b) The diff function changes. In this case runDiff is called from dvSetDiffFn + (which is an inner function of the diffFn attribute. + +> whenDiffLegal win diff_runner = +> dvGetState win >>= \st@(DVS _ fn1 fn2 _ _ _ _ may_diff _ _) -> +> get fn1 text >>= \orig -> +> get fn2 text >>= \update -> +> if (length orig /= 0) && (length update /= 0) +> then +> case may_diff of +> Just diff_fn -> diff_runner win diff_fn orig update st +> Nothing -> return () +> else +> return () + +================================================================================ + +Window Painting + +Most of the windows in the control can use their default paint functions, but +the two viewports for outputting diff information are custom controls based on +a Window type. These require special handling. + +The behaviour is slightly different here depending on whether the original file +or the changed file is being rendered. To indicate, we have a specific type, which +is curried into the selected on paint handler for each viewport. + +> data DVFileType = DVorig | DVchanged deriving Show + +On entry, win is the viewport window, DC is a suitable device context and +the rectangle which needs to be updated are provided. + +> onPaint parent file_type win dc r@(Rect x y w h) = +> wxcBeginBusyCursor >> +> getDisplayableText parent >>= \render_info -> +> renderDiff file_type parent win dc render_info >> +> wxcEndBusyCursor + +Determine the viewable text, i.e. the text which should be displayed in the viewport +we have opened on the virtual canvas. This is basically a question of working out the +row and column at which to start display, and the row and column at which we finish +display. + +Because the first few characters of the line contain characters which provide +information about the nature of the diff information, we cannot actually truncate +the lines to only the required text, and must instead provide this information +back to the final renderer. We do this in a data structure. + +> data RenderInfo = RI { ri_txt :: ![DiffLine] -- | Text to render +> , ri_firstcol :: !Int -- | First column to be used in text +> , ri_length :: !Int -- | Length of text to render +> } deriving Show + +Fetching the displayable text has a minor complication: some lines in the diff +hunk are not displayed in the diff windows (notably filenames and file location +information - see the definition of countDiffLines). + +The getDisplayableText function uses calcViewportTextExtent to determine the size of a +rectangle (in rows and columns of characters) on which text can be displayed, and the +selectLines function to select the correct number of displayable lines. + +The key values on the viewport text extend are: + - the 'y' position tells us the first line to render of the displayable lines. This + is dependent on the position of the vertical scroll bar, and is accounted for in + calcViewporttextExtent; + - the 'h' parameter tells us how many lines we need to render. + +> getDisplayableText win = +> calcViewportTextExtent win >>= \r@(Rect x y w _) -> +> dvGetState win >>= \(DVS _ _ _ _ _ _ _ _ _ map) -> +> let keys' = drop y $ Map.keys map +> (_, diff_lines) = foldl' (selectLines r map) (0,[]) keys' +> disp_diff = RI (reverse diff_lines) x w in +> return disp_diff + +Select lines which will be displayed on the viewport. Condition is: + - displayable lines with line number < y are above the viewport and not displayed + - displayable lines between line number y and line number y + h are displayed + - other lines are not displayed + +In addition, note that as not all lines are displayable, we need to keep a separate +account of the displayable line number as we iterate over the map. + +Note that it is legitimate to use fromJust on the output of Map.lookup because we +have fetched keys in the map, and it cannot be modified during the execution of this +function, so each lookup must succeed by definition. + +> selectLines :: Rect -> Map.Map Int DiffLine -> (Int, [DiffLine]) -> Int -> (Int, [DiffLine]) +> selectLines (Rect _ y _ h) map acc@(disp_line_no, strs) key +> | (disp_line_no < y) && (displayable typ) = (disp_line_no + 1, strs) +> | (disp_line_no < y + h) && (displayable typ) = (disp_line_no + 1, (DiffLine typ str) : strs) +> | otherwise = acc +> where +> (DiffLine typ str) = fromJust $ Map.lookup key map + +Displayable returns True if a line is displayable in a viewport. + +> displayable AddLine = True +> displayable DeleteLine = True +> displayable CommonLine = True +> displayable _ = False + +Render text in the selected font and colour scheme to the viewport windows. The +renderDiff function is responsible for creating device contexts on which the +rendering takes place and passes the actual rendering of text off to specific +functions which perform the formatting for the relevant line type. + +The displayable text is determined in disp_txt. This takes the displayable text +lines and removes the characters which need not be rendered to the viewport +(basically drops undisplayed characters from the start and end of each line) + +When clipping the text to be displayed, we retain the first character from the +diff text as this indicates which renderer to use. + +> renderDiff file_type parent win dc (RI diff_lines fst_col width) = +> dvGetState parent >>= \(DVS _ _ _ _ _ _ _ _ (DVF fs col bgcol spc) _ ) -> +> getFontMetrics win fs >>= \(FontMetrics x_max y_max desc el) -> +> get win clientSize >>= \(Size w h) -> +> set win [ color := col, bgcolor := bgcol ] >> +> set dc [ font := fs ] >> +> let disp_diff = map clipText diff_lines +> x_pos = 0 -- fst_col * (x_max + el) +> y_posns = map (\n -> n * (y_max + desc + spc)) [0..] +> diff_pos = zip disp_diff y_posns in +> mapM_ (\(diff, y_pos) -> renderLine file_type diff (Point x_pos y_pos) dc) diff_pos +> where +> clipText (DiffLine t s) = DiffLine t (take width (drop fst_col s)) + +Render a single line, selecting the appropriate renderer. + +> renderLine file_type (DiffLine t str) point dc = +> (getRenderer t) file_type str point dc + +Determine which renderer function to use + +> getRenderer OrigFileLine = nullRenderer +> getRenderer ChangeFileLine = nullRenderer +> getRenderer RangeLine = nullRenderer +> getRenderer AddLine = addRenderer +> getRenderer DeleteLine = delRenderer +> getRenderer CommonLine = ctxtRenderer +> getRenderer _ = nullRenderer + +Indicate what diff hunk information is contained on a line: + +> data DiffLineType = CommonLine +> | AddLine +> | DeleteLine +> | RangeLine +> | OrigFileLine +> | ChangeFileLine +> | UnknownLine +> deriving (Eq, Show) + +Determine the type of information represented in a diff line + +> getDiffLineType :: String -> DiffLineType +> getDiffLineType ('-':'-':'-':_) = OrigFileLine +> getDiffLineType ('+':'+':'+':_) = ChangeFileLine +> getDiffLineType ('@':'@':_) = RangeLine +> getDiffLineType ('+':_) = AddLine +> getDiffLineType ('-':_) = DeleteLine +> getDiffLineType (' ':_) = CommonLine +> getDiffLineType _ = UnknownLine + +The lines from a diff run are represented in a data type containing the +line type and the remaining text. + +> data DiffLine = DiffLine DiffLineType String +> deriving Show + +Parse diff lines into DiffLines data structures. + +> parseDiffLines = map parseDiffLine +> where +> parseDiffLine s = +> case getDiffLineType s of +> OrigFileLine -> DiffLine OrigFileLine (drop 3 s) +> ChangeFileLine -> DiffLine ChangeFileLine (drop 3 s) +> RangeLine -> DiffLine RangeLine (drop 2 s) +> AddLine -> DiffLine AddLine (tail s) +> DeleteLine -> DiffLine DeleteLine (tail s) +> CommonLine -> DiffLine CommonLine (tail s) +> UnknownLine -> DiffLine UnknownLine (tail s) + +Render Add line. This is presently configured to print added text in green. + +> addRenderer DVorig _ point dc = +> let spaces = replicate 100 '#' in +> setTextColours dc colour_silver colour_silver >> +> drawText dc spaces point [] +> addRenderer DVchanged txt point dc = +> setTextColours dc colour_green colour_white >> +> drawText dc txt point [] + +Render Delete line. This is presently configured to show deleted text in red. + +> delRenderer DVorig txt point dc = +> setTextColours dc colour_red colour_white >> +> drawText dc txt point [] +> delRenderer DVchanged _ point dc = +> let spaces = replicate 100 '#' in +> setTextColours dc colour_silver colour_silver >> +> drawText dc spaces point [] + +Render Unchanged line + +> ctxtRenderer _ txt point dc = +> setTextColours dc colour_black colour_white >> +> drawText dc txt point [] + +Null renderer can be used when there is nothing to render. + +> nullRenderer _ _ _ _ = return () + +Helper function for setting text colours + +> setTextColours dc fg bg = dcSetTextForeground dc fg >> +> dcSetTextBackground dc bg + +================================================================================ + +State management + +The underlying wxWidgets library is highly stateful and there is no +straightforward way to asbstract this, short of maintaining the whole GUI +within a state monad. + +The approach taken here is stateful, maintaining a per-control state (so that +multiple controls could be used in an application if required). A hash table, +keyed on the control ID (which is unique within a given wxWidgets application) +maintains state for all control instances. + +The control id is taken to be the identity of the outermost panel (i.e. the +dvs_panel field of the DiffViewerState type). + +Notice that the diff function and the formatting on each line are 'pluggable', +enabling the diff function and the formatting to be adapted to user requirements. + +> data DiffViewerState = DVS { dvs_panel :: DiffViewer () +> , dvs_fn1 :: StaticText () +> , dvs_fn2 :: StaticText () +> , dvs_f1 :: Window () +> , dvs_f2 :: Window () +> , dvs_vsb :: ScrollBar () +> , dvs_hsb :: ScrollBar () +> , dvs_diff :: Maybe (FilePath -> FilePath -> +> IO [String]) +> , dvs_fmt :: DiffViewerFormatting +> , dvs_txt :: Map.Map Int DiffLine +> } + +Formatting information is stored in a separate structure, to keep things +manageable. + +> data DiffViewerFormatting = DVF { dvf_font :: !FontStyle +> , dvf_colour :: !Color +> , dvf_bgcolour :: !Color +> , dvf_spacer :: !Int +> } deriving Show + +The default formatting is black text on white background, fixed width font +in 8 point text. + +> dvf_default = DVF { dvf_font = FontStyle 8 FontModern ShapeNormal WeightNormal False "" wxFONTENCODING_DEFAULT +> , dvf_colour = colorRGB 0 0 0 +> , dvf_bgcolour = colorRGB 255 255 255 +> , dvf_spacer = 0 +> } + +We maintain control state in a hash table. It is essential that this is not +inlined. + +> {-# noinline dv_states #-} +> dv_states :: Hash.HashTable Int DiffViewerState +> dv_states = unsafePerformIO $ Hash.new (==) (fromIntegral) + +We provide functions to fetch and update the state of a given DiffViewer + +> dvGetState :: DiffViewer a -> IO DiffViewerState +> dvGetState dv = +> windowGetId dv >>= \w -> +> Hash.lookup dv_states w >>= \result -> +> case result of +> Just r -> return r +> Nothing -> error ("dvGetState: lookup failed for window ID: " ++ show w) +> +> dvSetState :: DiffViewer a -> DiffViewerState -> IO () +> dvSetState dv st' = +> windowGetId dv >>= \w -> +> Hash.update dv_states w st' >> +> return () + +A common idiom is to fetch the state in order to update the value of a single +field. The dvModifyState function allows the updating to be expressed in terms +of a function - normally one which will use record getters and setters to +change the required field. + +> dvModifyState fn w s = +> dvGetState w >>= \dvs -> +> let dvs' = fn dvs s in +> dvSetState w dvs' + +================================================================================ + +Attributes + +Configure an attribute, diffFn, which will be used by the owning application +to set the function which will perform the diff operation. Notice that it is +possible for no diff function to be set. + +Notice also that the diff function may be executed when the diffFn attribute +is set. + +> diffFn :: Attr (DiffViewer a) (Maybe (FilePath -> FilePath -> IO [String])) +> diffFn = newAttr "diffFn" dvGetDiffFn dvSetDiffFn +> where +> dvGetDiffFn = (liftM dvs_diff) . dvGetState +> dvSetDiffFn win diff_fn = +> dvModifyState (\st s -> st { dvs_diff = s } ) win diff_fn >> +> whenDiffLegal win runDiff + +The diffFiles attribute controls selection of the files to which diff function +will be applied. + +When files are set, we clear the diff map (because our existing diff text is +invalidated) and possibly (if the file names are non empty) run a new diff function. + +A consequence of this design is that setting the files to "" will clear the diff +control. + +> diffFiles :: Attr (DiffViewer a) (FilePath, FilePath) +> diffFiles = newAttr "diffFiles" dvGetFiles dvSetFiles +> where +> dvGetFiles win = +> dvGetState win >>= \(DVS _ fn1 fn2 _ _ _ _ _ _ _) -> +> get fn1 text >>= \txt1 -> +> get fn2 text >>= \txt2 -> +> return (txt1, txt2) +> dvSetFiles win (txt1, txt2) = +> dvGetState win >>= \st@(DVS _ fn1 fn2 _ _ _ _ _ _ _) -> +> let st' = st { dvs_txt = Map.empty } in +> set fn1 [text := txt1] >> +> set fn2 [text := txt2] >> +> dvSetState win st' >> +> whenDiffLegal win runDiff + +The control has configurable fonts and the like, so it has been made an +instance of Literate. Note, however, that changing textColor only affects +unmodified text (modified text has pre-defined colour attributes). + +> instance Literate (DiffViewer a) where +> font = newAttr "font" dvGetFont dvSetFont +> fontSize = newAttr "fontSize" dvGetFontSize dvSetFontSize +> fontWeight = newAttr "fontWeight" dvGetFontWeight dvSetFontWeight +> fontFamily = newAttr "fontFamily" dvGetFontFamily dvSetFontFamily +> fontShape = newAttr "fontShape" dvGetFontShape dvSetFontShape +> fontFace = newAttr "fontFace" dvGetFontFace dvSetFontFace +> fontUnderline = newAttr "fontUnderline" dvGetFontUnderline dvSetFontUnderline +> textColor = newAttr "textColor" dvGetTextColor dvSetTextColor +> textBgcolor = newAttr "textBgcolor" dvGetTextBgColor dvSetTextBgColor + +Modify the dvs_fmt field in a DiffViewerState, applying an updating function to +change the existing value in the field. + +> dvModifyFmt fn = dvModifyState (\dvs s -> dvs { dvs_fmt = fn (dvs_fmt dvs) s }) + +Modify the dvf_font field of the dvs_fmt field in a DiffViewerState, applying an +updating function to change the existing value in the field. + +> dvModifyFont fn = dvModifyFmt (\dvf s -> dvf { dvf_font = fn (dvf_font dvf) s }) + +All of the Literate attribute getters and setters are expressed in terms of +dvGetState, dvModifyFont or dvModifyFmt + +> dvGetFont = (liftM (dvf_font . dvs_fmt)) . dvGetState +> dvSetFont = dvModifyFmt (\st s -> st { dvf_font = s }) +> dvGetFontSize = (liftM _fontSize) . dvGetFont +> dvSetFontSize = dvModifyFont (\st s -> st { _fontSize = s }) +> dvGetFontWeight = (liftM _fontWeight) . dvGetFont +> dvSetFontWeight = dvModifyFont (\st s -> st { _fontWeight = s }) +> dvGetFontFamily = (liftM _fontFamily) . dvGetFont +> dvSetFontFamily = dvModifyFont (\st s -> st { _fontFamily = s }) +> dvGetFontShape = (liftM _fontShape) . dvGetFont +> dvSetFontShape = dvModifyFont (\st s -> st { _fontShape = s }) +> dvGetFontFace = (liftM _fontFace) . dvGetFont +> dvSetFontFace = dvModifyFont (\st s -> st { _fontFace = s }) +> dvGetFontUnderline = (liftM _fontUnderline) . dvGetFont +> dvSetFontUnderline = dvModifyFont (\st s -> st { _fontUnderline = s }) +> dvGetTextColor = (liftM (dvf_colour . dvs_fmt)) . dvGetState +> dvSetTextColor = dvModifyFmt (\st s -> st { dvf_colour = s }) +> dvGetTextBgColor = (liftM (dvf_bgcolour . dvs_fmt)) . dvGetState +> dvSetTextBgColor = dvModifyFmt (\st s -> st { dvf_bgcolour = s }) + +================================================================================ + +Display contents of the diff boxes... + +The number of lines of diff information can be calculated as follows: + + - Any '---' and '+++' lines are ignored + - Any '@@' lines are ignored + - Lines starting ' ', '-' or '+' are displayable lines + - Blank lines are displayable (a horizontal line) + +> countDiffLines map = Map.fold countDiffLines' 0 map +> where +> countDiffLines' (DiffLine typ _) acc | displayable typ = acc + 1 +> | otherwise = acc + +Based on the fontmetrics for a device context on one of the file display windows +(they are both the same in this respect), we can work out the size of a virtual +window which would contain the entire diff text. + +We set both of the diff client windows to have the virtual size of this notional canvas +and we work within a viewport onto this virtual canvas. We also configure the scroll bars +so that they range over the virtual canvas correctly. + +> setVirtualCanvas w = +> dvGetState w >>= \(DVS _ _ _ vp1 vp2 vs hs _ (DVF fs _ _ spacer) m) -> +> get vp1 clientSize >>= \cs1 -> +> get vp2 clientSize >>= \cs2 -> +> getFontMetrics vp1 fs >>= \(FontMetrics x_max y_max desc el) -> +> let textSize = calcTextSize m +> char_height = y_max + desc + spacer +> char_width = x_max + el +> canvas_sz = sz (char_width * (sizeW textSize)) (char_height * (sizeH textSize)) in +> set vp1 [ virtualSize := canvas_sz ] >> +> set vp2 [ virtualSize := canvas_sz ] >> +> adjustScrollbars w + +Calculate the number of rows and columns required to completely fit the diff text +(i.e. the number of lines and the length of the longest line). This is a key input +into the calculation of the virtual canvas size. + +> calcTextSize :: Map.Map Int DiffLine -> Size +> calcTextSize m = sz (longestString m) (countDiffLines m) +> where +> longestString m = Map.fold (\(DiffLine _ str) max_now -> max (length str) max_now) 0 m + +Adjust the scroll bars to represent the correct view over the data in the viewport. +For the purposes of calculation, assume that both viewports are the same size (they +will be clipped anyway, so worst case is that we do a little more work than strictly +required). + +Scroll bars are configured with a range (number of rows/columns of text) and a thumb +size (number of rows/columns visible in the viewport). + +> adjustScrollbars w = +> dvGetState w >>= \(DVS _ _ _ _ _ vs hs _ _ map) -> +> calcViewportTextSize w >>= \(Size x_cs_txt y_cs_txt) -> +> let (Size x_txt y_txt) = calcTextSize map in +> -- Save scroll position before updating +> scrollBarGetThumbPosition vs >>= \vs_pos -> +> scrollBarGetThumbPosition hs >>= \hs_pos -> +> scrollBarSetScrollbar vs vs_pos y_cs_txt y_txt y_cs_txt True >> +> scrollBarSetScrollbar hs hs_pos x_cs_txt x_txt x_cs_txt True + +This is straightforward: the scroll bars give the starting row/column from their +current position. We know the end row/column by calculating the viewport text +size. Thus we obtain a starting row/column and an end row/column to display. + +> calcViewportTextExtent w = +> dvGetState w >>= \(DVS _ _ _ _ _ vs hs _ _ map) -> +> scrollBarGetThumbPosition vs >>= \top_left_y -> +> scrollBarGetThumbPosition hs >>= \top_left_x -> +> calcViewportTextSize w >>= \(Size bot_right_raw_x bot_right_raw_y) -> +> let (Size max_x max_y) = calcTextSize map +> width = min bot_right_raw_x (max_x - top_left_x) +> height = min bot_right_raw_y (max_y - top_left_y) +> textExtent = Rect top_left_x top_left_y width height in +> return textExtent + +Calculate how much text we can fit into the viewport. This is straightforward: on +each axis, the ratio of virtual canvas extent to viewport canvas extent (i.e. in +device context units) is the same as the ratio of the total number of rows/columns +to the viewable rows/columns. + +Notice that the virtualSize is updated to a minimum size of (1,1). This is to +ensure that no divide by zero error is possible when calculating x_cs_txt and +y_cs_txt. + +> calcViewportTextSize w = +> dvGetState w >>= \(DVS _ _ _ vp1 _ _ _ _ _ map) -> +> get vp1 clientSize >>= \(Size x_cs y_cs) -> +> get vp1 virtualSize >>= \(Size x_vs y_vs) -> +> let (Size x_vs_txt y_vs_txt) = calcTextSize map +> x_vs' = max 1 x_vs +> y_vs' = max 1 y_vs +> x_cs_txt = min ((x_cs * x_vs_txt) `div` x_vs') x_vs_txt +> y_cs_txt = min ((y_cs * y_vs_txt) `div` y_vs') y_vs_txt +> cs_txt = sz x_cs_txt y_cs_txt in +> return cs_txt + +================================================================================ + +Colours + +We use the standard colour names/spaces defined in the W3C CSS specification. + +> colour_silver = colorRGB 192 192 192 +> colour_black = colorRGB 0 0 0 +> colour_green = colorRGB 0 128 0 +> colour_white = colorRGB 255 255 255 +> colour_red = colorRGB 255 0 0 diff --git a/src/Graphics/UI/WXContrib/WXFontMetrics.hs b/src/Graphics/UI/WXContrib/WXFontMetrics.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WXContrib/WXFontMetrics.hs @@ -0,0 +1,72 @@ +{- + Copyright (C) Jeremy O'Donoghue (jeremy.odonoghue@gmail.com) 2007-2010. + 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. + + The name of Jeremy O'Donoghue may not 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 HOLDER 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. +-} + +module Graphics.UI.WXContrib.WXFontMetrics + ( FontMetrics(..) + , getFontMetrics + ) + where + +import Graphics.UI.WXCore +import Graphics.UI.WX + +-- | FontMetrics for a given device context. +data FontMetrics = FontMetrics { fm_x :: !Int -- | Largest X value + , fm_y :: !Int -- | Largest Y value + , fm_desc :: !Int -- | Largest value of descender + , fm_el :: !Int -- | Largest external leader + } deriving Show + + +-- | Return font metrics (based on several selected characters) for +-- a single character in a given window based on the supplied text +-- attributes. An attempt is made to determine the maximum likely +-- space needed for any character in the font, although the reality +-- is that this is inevitably somewhat font dependent. +getFontMetrics :: Window a -> FontStyle -> IO FontMetrics +getFontMetrics win font = + do + dc <- windowDCCreate win + dcSetFontStyle dc font + (sz1, d1, el1) <- getFullTextExtent dc "W" -- A wide character + (sz2, d2, el2) <- getFullTextExtent dc "y" -- A character with descender + (sz3, d3, el3) <- getFullTextExtent dc "l" -- May have external leading + let szx1 = sizeW sz1 + szy1 = sizeH sz1 + szx2 = sizeW sz2 + szy2 = sizeH sz2 + szx3 = sizeW sz3 + szy3 = sizeH sz3 + fm = FontMetrics (maximum [szx1, szx2, szx3]) -- Largest X value for size + (maximum [szy1, szy2, szy3]) -- Largest Y value for size + (maximum [d1, d2, d3]) -- Largest value of descender + (maximum [el1, el2, el3]) -- Largest value of external leading + windowDCDelete dc + return fm