GenI-0.20: src/NLP/GenI/GuiHelper.hs
-- GenI surface realiser
-- Copyright (C) 2005 Carlos Areces and Eric Kow
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License
-- as published by the Free Software Foundation; either version 2
-- of the License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
{-# LANGUAGE FlexibleContexts #-}
module NLP.GenI.GuiHelper where
import Graphics.UI.WX
-- import Graphics.UI.WXCore
import Control.Arrow ( (&&&), (***) )
import qualified Control.Monad as Monad
import Control.Monad.State.Strict ( execStateT, runState )
import qualified Data.Map as Map
import Data.IORef
import System.Directory
import System.FilePath ((<.>),(</>),dropExtensions)
import System.Process (runProcess)
import Text.ParserCombinators.Parsec (parseFromFile)
import NLP.GenI.Graphviz
import NLP.GenI.Automaton (numStates, numTransitions)
import NLP.GenI.Configuration ( getFlagP, MacrosFlg(..), ViewCmdFlg(..) )
import NLP.GenI.GeniShow(geniShow)
import NLP.GenI.GraphvizShow ()
import NLP.GenI.Tags (TagItem(tgIdName), tagLeaves)
import NLP.GenI.Geni
( ProgState(..) )
import NLP.GenI.GeniParsers ( geniTagElems )
import NLP.GenI.General
(geniBug, boundsCheck, dropTillIncluding, ePutStrLn)
import NLP.GenI.Btypes
( showAv, showPred, showLexeme, )
import NLP.GenI.PolarityTypes ( PolarityKey(..) )
import NLP.GenI.Tags
( idname, mapBySem, TagElem(ttrace, tinterface) )
import NLP.GenI.Configuration
( Params(..), MetricsFlg(..), setFlagP )
import qualified NLP.GenI.Builder as B
import NLP.GenI.Builder (queryCounter, num_iterations, chart_size,
num_comparisons)
import NLP.GenI.Polarity (PolAut, detectPolFeatures)
import NLP.GenI.GraphvizShowPolarity ()
-- ----------------------------------------------------------------------
-- Types
-- ----------------------------------------------------------------------
data GraphvizStatus = GvError String
| GvNoSuchItem Int
| GvCached
| GvCreated FilePath
deriving Show
-- ----------------------------------------------------------------------
-- Lexically selected items
-- ----------------------------------------------------------------------
-- | 'candidateGui' displays the lexically selected items, grouped by the
-- semantics they subsume.
candidateGui :: ProgState
-> Window a
-> [TagElem]
-> GvIO () Bool (Maybe TagElem)
candidateGui pst f xs = do
p <- panel f []
(tb,gvRef,updater) <- tagViewerGui pst p "lexically selected item" "candidates"
$ sectionsBySem xs
let polFeats = "Polarity attributes detected: " ++ (unwords.detectPolFeatures) xs
warning = unlines $ filter (not.null) (polFeats : warnings pst)
-- side panel
sidePnl <- panel p []
ifaceLst <- singleListBox sidePnl [ tooltip := "interface for this tree (double-click me!)" ]
traceLst <- singleListBox sidePnl [ tooltip := "trace for this tree (double-click me!)" ]
tNoted <- textCtrl sidePnl [ wrap := WrapWord, text := "Hint: copy from below and paste into the sem:\n" ]
let laySide = container sidePnl $ column 2
[ label "interface"
, fill $ widget ifaceLst
, label "trace"
, fill $ widget traceLst
, label "notes"
, fill $ widget tNoted ]
-- handlers
let addLine :: String -> String -> String
addLine x y = y ++ "\n" ++ x
--
addToNoted w =
do sel <- get w selection
things <- get w items
when (sel > 0) $ set tNoted [ text :~ addLine (things !! sel) ]
set ifaceLst [ on doubleClick := \_ -> addToNoted ifaceLst ]
set traceLst [ on doubleClick := \_ -> addToNoted traceLst ]
-- updaters : what happens when the user selects an item
let updateTrace = gvOnSelect (return ())
(\s -> set traceLst [ items := ttrace s ])
updateIface = gvOnSelect (return ())
(\s -> set ifaceLst [ items := map showAv $ tinterface s ])
Monad.unless (null xs) $ do
addGvHandler gvRef updateTrace
addGvHandler gvRef updateIface
-- first time run
gvSt <- readIORef gvRef
updateIface gvSt
updateTrace gvSt
--
let layMain = fill $ row 2 [ fill tb, vfill laySide ]
theItems = if null warning then [ layMain ] else [ hfill (label warning) , layMain ]
lay = fill $ container p $ column 5 theItems
return (lay, gvRef, updater)
sectionsBySem :: (TagItem t) => [t] -> [ (Maybe t, String) ]
sectionsBySem tsem =
let semmap = mapBySem tsem
sem = Map.keys semmap
--
lookupTr k = Map.findWithDefault [] k semmap
section k = (Nothing, header) : (map tlab $ lookupTr k)
where header = "___" ++ showPred k ++ "___"
tlab t = (Just t, tgIdName t)
in concatMap section sem
-- ----------------------------------------------------------------------
-- Polarity Automata
-- ----------------------------------------------------------------------
-- | A browser to see the automata constructed during the polarity optimisation
-- step.
polarityGui :: (Window a) -> [(PolarityKey,PolAut,PolAut)] -> PolAut
-> GvIO () () PolAut
polarityGui f xs final = do
let stats a = " (" ++ (show $ numStates a) ++ "st " ++ (show $ numTransitions a) ++ "tr)"
aut2 (_ , a1, a2) = [ a1, a2 ]
autLabel (PolarityKey fv,a1,a2) = [ fv ++ stats a1, fv ++ " pruned" ++ stats a2]
finalAutLab = ( final, "final" ++ stats final )
autslabs = concatBoth (map (aut2 &&& autLabel) xs) ++ [ finalAutLab ]
gvRef <- newGvRef () () "automata"
setGvDrawables gvRef autslabs
graphvizGui f "polarity" gvRef
concatBoth :: [ ([a],[b]) ] -> [ (a,b) ]
concatBoth = uncurry zip . (concat *** concat) . unzip -- is there a simpler way?
-- ----------------------------------------------------------------------
-- Helpers
-- ----------------------------------------------------------------------
-- | Any data structure which has corresponds to a TAG tree and which
-- has some notion of derivation
class XMGDerivation a where
getSourceTrees :: a -> [String]
instance XMGDerivation TagElem where
getSourceTrees te = [idname te]
-- | 'toSentence' almost displays a 'TagElem' as a sentence, but only good
-- enough for debugging needs. The problem is that each leaf may be
-- an atomic disjunction. Our solution is just to display each choice and
-- use some delimiter to seperate them. We also do not do any
-- morphological processing.
toSentence :: TagElem -> String
toSentence = unwords . map squishLeaf . tagLeaves
squishLeaf :: (a,([String], b)) -> String
squishLeaf = showLexeme.fst.snd
-- ----------------------------------------------------------------------
-- TAG viewer
-- ----------------------------------------------------------------------
-- | Variant of 'graphvizGui' with a toggle to view feature structures
tagViewerGui :: (GraphvizShow Bool t, TagItem t, XMGDerivation t)
=> ProgState -> (Window a) -> String -> String -> [(Maybe t,String)]
-> GvIO () Bool (Maybe t)
tagViewerGui pst f tip cachedir itNlab = do
p <- panel f []
gvRef <- newGvRef () False tip
setGvDrawables gvRef itNlab
(lay,ref,onUpdate) <- graphvizGui p cachedir gvRef
-- button bar widgets
detailsChk <- checkBox p [ text := "Show features"
, checked := False ]
viewTagLay <- viewTagWidgets p gvRef (pa pst)
-- handlers
let onDetailsChk =
do isDetailed <- get detailsChk checked
setGvParams gvRef isDetailed
onUpdate
set detailsChk [ on command := onDetailsChk ]
-- pack it all in
let cmdBar = hfill $ row 5
[ dynamic $ widget detailsChk
, viewTagLay ]
lay2 = fill $ container p $ column 5 [ fill lay, cmdBar ]
return (lay2,ref,onUpdate)
-- ----------------------------------------------------------------------
-- XMG Metagrammar stuff.
-- See <http://sourcesup.cru.fr/xmg/>
-- ----------------------------------------------------------------------
-- | Calls Yannick Parmentier's handy visualisation tool ViewTAG.
viewTagWidgets :: (GraphvizShow Bool t, TagItem t, XMGDerivation t)
=> Window a -> GraphvizGuiRef st (Maybe t) Bool -> Params
-> IO Layout
viewTagWidgets p gvRef config =
do viewTagBtn <- button p [ text := "ViewTAG" ]
viewTagCom <- choice p [ tooltip := "derivation tree" ]
-- handlers
let onViewTag = readIORef gvRef >>=
gvOnSelect (return ())
(\t -> do let derv = getSourceTrees t
ds <- get viewTagCom selection
if boundsCheck ds derv
then runViewTag config (derv !! ds)
else geniBug $ "Gui: bounds check in onViewTag"
)
set viewTagBtn [ on command := onViewTag ]
-- when the user selects a tree, we want to update the list of derivations
let updateDerivationList = gvOnSelect
(set viewTagCom [ enabled := False ])
(\s -> set viewTagCom [ enabled := True
, items := getSourceTrees s
, selection := 0] )
addGvHandler gvRef updateDerivationList
updateDerivationList =<< readIORef gvRef
--
return $ row 5 $ map dynamic [ widget viewTagCom, widget viewTagBtn ]
runViewTag :: Params -> String -> IO ()
runViewTag params drName =
case getFlagP MacrosFlg params of
Nothing -> ePutStrLn "Warning: No macros files specified (runViewTag)"
Just f -> do
-- figure out what grammar file to use
let gramfile = dropExtensions f <.> "rec"
treenameOnly = takeWhile (/= ':') . dropTillIncluding ':' . dropTillIncluding ':'
-- run the viewer
case getFlagP ViewCmdFlg params of
Nothing -> ePutStrLn "Warning: No viewcmd specified (runViewTag)"
Just c -> do -- run the viewer
runProcess c [gramfile, treenameOnly drName]
Nothing Nothing Nothing Nothing Nothing
return ()
-- --------------------------------------------------------------------
-- Graphical debugger (helper functions)
-- --------------------------------------------------------------------
-- | 'pauseOnLexGui' allows the user to see lexical selection only and either
-- dump it to file or read replace it by the contents of some other file
pauseOnLexGui :: ProgState -> (Window a) -> [TagElem]
-> ([TagElem] -> IO ()) -- ^ continuation
-> GvIO () Bool (Maybe TagElem)
pauseOnLexGui pst f xs job = do
p <- panel f []
candV <- varCreate xs
(tb, ref, updater) <- candidateGui pst p xs
-- supplementary button bar
let saveCmd =
do c <- varGet candV
let cStr = unlines $ map geniShow c
maybeSaveAsFile f cStr
loadCmd =
do let filetypes = [("Any file",["*","*.*"])]
fsel <- fileOpenDialog f False True "Choose your file..." filetypes "" ""
case fsel of
Nothing -> return ()
Just file ->
do parsed <- parseFromFile geniTagElems file
case parsed of
Left err -> errorDialog f "" (show err)
Right c -> do varSet candV c
setGvDrawables ref (sectionsBySem c)
updater
--
saveBt <- button p [ text := "Save to file", on command := saveCmd ]
loadBt <- button p [ text := "Load from file", on command := loadCmd ]
nextBt <- button p [ text := "Begin" ]
let disableW w = set w [ enabled := False ]
set nextBt [ on command := do mapM disableW [ saveBt, loadBt, nextBt ]
varGet candV >>= job ]
--
let lay = fill $ container p $ column 5
[ fill tb, hfill (vrule 1)
, row 0 [ row 5 [ widget saveBt, widget loadBt ]
, hfloatRight $ widget nextBt ] ]
return (lay, ref, updater)
type DebuggerItemBar st flg itm
= Panel () -- ^ parent panel
-> GraphvizGuiRef st (Maybe itm) flg -- ^ gv ref to use
-> GvUpdater -- ^ onUpdate
-> IO (Layout, GvUpdater)
-- | A generic graphical debugger widget for GenI, including
--
-- * item viewer which allows the user to select one of the items in the
-- builder state.
--
-- * item bar which provides some options on how to view the currently
-- selected item, for example, if you want to display the features or not.
--
-- * A dashboard which lets the user do things like ``go ahead 6 steps''.
--
-- Besides the Builder, there are two functions you need to pass in make this
-- work:
--
-- 1. a 'stateToGv' which converts the builder state into a list of items
-- and labels the way 'graphvizGui' likes it
--
-- 2. an 'item bar' function which lets you control what bits you display
-- of a selected item (for example, if you want a detailed view or not)
-- the item bar should return a layout
--
-- Note that we don't constrain the type of item returned by the builder to
-- be the same as the type handled by your gui: that's quite normal because
-- you might want to decorate the type with some other information
debuggerPanel :: (GraphvizShow flg itm)
=> B.Builder st itm2 Params -- ^ builder to use
-> flg -- ^ initial value for the flag argument in GraphvizShow
-> (st -> [(Maybe itm, String)])
-- ^ function to convert a Builder state into lists of items
-- and their labels, the way graphvizGui likes it
-> (DebuggerItemBar st flg itm)
-- ^ 'itemBar' function returning a control panel configuring
-- how you want the currently selected item in the debugger
-- to be displayed
-> (Window a) -- ^ parent window
-> Params -- ^ geni params
-> B.Input -- ^ builder input
-> String -- ^ graphviz cache directory
-> IO Layout
debuggerPanel builder gvInitial stateToGv itemBar f config input cachedir =
do let initBuilder = B.init builder
nextStep = B.step builder
allSteps = B.stepAll builder
--
let (initS, initStats) = initBuilder input config2
config2 = setFlagP MetricsFlg (B.defaultMetricNames) config
p <- panel f []
-- ---------------------------------------------------------
-- item viewer: select and display an item
-- ---------------------------------------------------------
gvRef <- newGvRef initS gvInitial "debugger session"
setGvDrawables gvRef (stateToGv initS)
(layItemViewer,_,onUpdateMain) <- graphvizGui p cachedir gvRef
-- ----------------------------------------------------------
-- item bar: controls for how an individual item is displayed
-- ----------------------------------------------------------
(layItemBar,onUpdateItemBar) <- itemBar p gvRef onUpdateMain
-- -------------------------------------------
-- dashboard: controls for the debugger itself
-- -------------------------------------------
let onUpdate = onUpdateMain >> onUpdateItemBar
db <- panel p []
restartBt <- button db [text := "Start over"]
nextBt <- button db [text := "Step by..."]
leapVal <- entry db [ text := "1", clientSize := sz 30 25 ]
finishBt <- button db [text := "Leap to end"]
statsTxt <- staticText db []
-- dashboard commands
let showQuery c gs = case queryCounter c gs of
Nothing -> "???"
Just q -> show q
updateStatsTxt gs = set statsTxt [ text :~ (\_ -> txtStats gs) ]
txtStats gs = unwords [ "itr", showQuery num_iterations gs
, "chart sz", showQuery chart_size gs
]
++ "\ncomparisons: " ++ showQuery num_comparisons gs
let genStep _ (st,stats) = runState (execStateT nextStep st) stats
let showNext s_stats =
do leapTxt <- get leapVal text
let leapInt :: Integer
leapInt = read leapTxt
(s2,stats2) = foldr genStep s_stats [1..leapInt]
modifyIORef gvRef $ \g -> g { gvcore = s2 }
setGvDrawables gvRef (stateToGv s2)
setGvSel gvRef 1
onUpdate
updateStatsTxt stats2
set nextBt [ on command :~ (\_ -> showNext (s2,stats2) ) ]
let showLast =
do -- redo generation from scratch
let (s2, stats2) = runState (execStateT allSteps initS) initStats
setGvDrawables gvRef (stateToGv s2)
onUpdate
updateStatsTxt stats2
let showReset =
do set nextBt [ on command := showNext (initS, initStats) ]
updateStatsTxt initStats
setGvDrawables gvRef (stateToGv initS)
setGvSel gvRef 1
onUpdate
-- dashboard handlers
set finishBt [ on command := showLast ]
set restartBt [ on command := showReset ]
showReset
-- dashboard layout
let layCmdBar = hfill $ container db $ row 5
[ widget statsTxt, hfloatRight $ row 5
[ widget restartBt, widget nextBt
, widget leapVal, label " step(s)"
, widget finishBt ] ]
-- -------------------------------------------
-- overall layout
-- -------------------------------------------
return $ fill $ container p $ column 5 [ layItemViewer, layItemBar, hfill (vrule 1), layCmdBar ]
-- --------------------------------------------------------------------
-- Graphviz GUI
-- --------------------------------------------------------------------
data GraphvizOrder = GvoParams | GvoItems | GvoSel
deriving Eq
data GraphvizGuiSt st a b =
GvSt { gvcore :: st,
gvitems :: Map.Map Int a,
gvparams :: b,
gvlabels :: [String],
-- | tooltip for the selection box
gvtip :: String,
-- | handler function to call when the selection is
-- updated (note: before displaying the object)
gvhandler :: Maybe (GraphvizGuiSt st a b -> IO ()),
gvsel :: Int,
gvorders :: [GraphvizOrder] }
-- | This provides a mechanism for communicating with the GUI. The basic idea:
--
-- 1. you create a GvRef with newGvRef
--
-- 2. you call 'graphvizGui' and get back an updater function
--
-- 3. whenever you want to modify something, you use setGvWhatever and call
-- the updater function
--
-- 4. if you want to react to the selection being changed, you should set
-- gvhandler
type GraphvizGuiRef st a b = IORef (GraphvizGuiSt st a b)
newGvRef :: st -> b -> String -> IO (GraphvizGuiRef st a b)
newGvRef initSt p t =
let st = GvSt { gvcore = initSt,
gvparams = p,
gvitems = Map.empty,
gvlabels = [],
gvhandler = Nothing,
gvtip = t,
gvsel = 0,
gvorders = [] }
in newIORef st
setGvSel :: GraphvizGuiRef st a b -> Int -> IO ()
setGvSel gvref s =
do let fn x = x { gvsel = s,
gvorders = GvoSel : (gvorders x) }
modifyIORef gvref fn
setGvParams :: GraphvizGuiRef st a b -> b -> IO ()
setGvParams gvref c =
do let fn x = x { gvparams = c,
gvorders = GvoParams : (gvorders x) }
modifyIORef gvref fn
modifyGvParams :: GraphvizGuiRef st a b -> (b -> b) -> IO ()
modifyGvParams gvref fn =
do gvSt <- readIORef gvref
setGvParams gvref (fn $ gvparams gvSt)
setGvDrawables :: GraphvizGuiRef st a b -> [(a,String)] -> IO ()
setGvDrawables gvref itlb =
do let (it,lb) = unzip itlb
fn x = x { gvitems = Map.fromList $ zip [0..] it
, gvlabels = lb
, gvorders = GvoItems : (gvorders x)
}
modifyIORef gvref fn
-- | Helper function for making selection handlers (see 'addGvHandler')
-- Note that this was designed for cases where the contents is a Maybe
gvOnSelect :: IO () -> (a -> IO ()) -> GraphvizGuiSt st (Maybe a) b -> IO ()
gvOnSelect onNothing onJust gvSt =
let sel = gvsel gvSt
things = gvitems gvSt
in case Map.lookup sel things of
Just (Just s) -> onJust s
_ -> onNothing
setGvHandler :: GraphvizGuiRef st a b -> Maybe (GraphvizGuiSt st a b -> IO ()) -> IO ()
setGvHandler gvref mh =
do gvSt <- readIORef gvref
modifyIORef gvref (\x -> x { gvhandler = mh })
case mh of
Nothing -> return ()
Just fn -> fn gvSt
-- | add a selection handler - if there already is a handler
-- this handler will be called before the new one
addGvHandler :: GraphvizGuiRef st a b -> (GraphvizGuiSt st a b -> IO ()) -> IO ()
addGvHandler gvref h =
do gvSt <- readIORef gvref
let newH = case gvhandler gvSt of
Nothing -> Just h
Just oldH -> Just (\g -> oldH g >> h g)
setGvHandler gvref newH
type GvIO st f d = IO (Layout, GraphvizGuiRef st d f, GvUpdater)
type GvUpdater = IO ()
-- |'graphvizGui' @f glab cachedir gvRef@ is a general-purpose GUI for
-- displaying a list of items graphically via AT&T's excellent Graphviz
-- utility. We have a list box where we display all the labels the user
-- provided. If the user selects an entry from this box, then the item
-- corresponding to that label will be displayed.
--
-- This returns a layout (wxhaskell container) and a function that you're
-- expected to call whever something changes that would require the GUI to
-- refresh itself (for example, you create a new chart item)
--
-- * @f@ - (parent window) the GUI is provided as a panel within the parent.
-- Note: we use window in the WxWidget's sense, meaning it could be
-- anything as simple as a another panel, or a notebook tab.
-- * @glab@ - (gui labels) a tuple of strings (tooltip, next button text)
-- * @cachedir@ - the cache subdirectory. We intialise this by creating a cache
-- directory for images which will be generated from the results
-- * @gvRef@ - see above
graphvizGui :: (GraphvizShow f d) => (Window a) -> String -> GraphvizGuiRef st d f -> GvIO st f d
graphvizGui f cachedir gvRef = do
initGvSt <- readIORef gvRef
-- widgets
p <- panel f [ fullRepaintOnResize := False ]
split <- splitterWindow p []
(dtBitmap,sw) <- scrolledBitmap split
rchoice <- singleListBox split [tooltip := gvtip initGvSt]
-- set handlers
let openFn = openImage sw dtBitmap
-- pack it all together
let lay = fill $ container p $ margin 1 $ fill $
vsplit split 5 200 (widget rchoice) (widget sw)
set p [ on closing := closeImage dtBitmap ]
------------------------------------------------
-- create an updater function
------------------------------------------------
let withoutSelector job =
bracket ( swap rchoice (on select) (return ()) )
( \fn -> set rchoice [ on select := fn ] )
( const job )
-- the selector calls onUpdate which calls the selector
-- indirectly by setting the selection
let onUpdate = withoutSelector $ do
gvSt <- readIORef gvRef
let orders = gvorders gvSt
initCacheDir cachedir
Monad.when (GvoItems `elem` orders) $
set rchoice [ items := gvlabels gvSt ]
Monad.when (GvoSel `elem` orders) $
set rchoice [ selection := gvsel gvSt ]
modifyIORef gvRef (\x -> x { gvorders = []})
createAndOpenImage cachedir p gvRef openFn
------------------------------------------------
-- enable the tree selector
-- FIXME: not sure that this is correct
------------------------------------------------
let selectAndShow = do
-- putStrLn "selectAndShow called"
sel <- get rchoice selection
-- note: do not use setGvSel (infinite loop)
modifyIORef gvRef (\x -> x { gvsel = sel })
-- call the handler if there is one
gvSt <- readIORef gvRef
case (gvhandler gvSt) of
Nothing -> return ()
Just h -> h gvSt
-- now do the update
onUpdate
------------------------------------------------
set rchoice [ on select := selectAndShow ]
-- call the updater function for the first time
setGvSel gvRef 1
onUpdate
-- return the layout, the gvRef, and an updater function
-- The gvRef is to make it easier for users to muck around with the
-- state of the gui. Here, it's trivial, but when people combine guis
-- together, it might be easier to keep track of when returned
return (lay, gvRef, onUpdate)
-- ----------------------------------------------------------------------
-- Bitmap stuff
-- ----------------------------------------------------------------------
-- | Bitmap with a scrollbar
scrolledBitmap :: Window a -> IO(VarBitmap, ScrolledWindow ())
scrolledBitmap p = do
dtBitmap <- variable [value := Nothing]
sw <- scrolledWindow p [scrollRate := sz 10 10, bgcolor := white,
on paint := onPaint dtBitmap,
fullRepaintOnResize := False ]
return (dtBitmap, sw)
type OpenImageFn = FilePath -> IO ()
type VarBitmap = Var (Maybe (Bitmap ()))
openImage :: Window a -> VarBitmap -> OpenImageFn
openImage sw vbitmap fname = do
-- load the new bitmap
bm <- bitmapCreateFromFile fname -- can fail with exception
closeImage vbitmap
set vbitmap [value := Just bm]
-- reset the scrollbars
bmsize <- get bm size
set sw [virtualSize := bmsize]
repaint sw
`catch` \_ -> repaint sw
closeImage :: VarBitmap -> IO ()
closeImage vbitmap = do
mbBitmap <- swap vbitmap value Nothing
case mbBitmap of
Nothing -> return ()
Just bm -> objectDelete bm
onPaint :: VarBitmap -> DC a -> b -> IO ()
onPaint vbitmap dc _ = do
mbBitmap <- get vbitmap value
case mbBitmap of
Nothing -> return ()
Just bm -> do dcClear dc
drawBitmap dc bm pointZero False []
-- | 'createAndOpenImage' attempts to draw an image (or retrieve it from cache)
-- and opens it if we succeed. Otherwise, it does nothing at all; the creation
-- function will display an error message if it fails.
createAndOpenImage :: (GraphvizShow f b) =>
FilePath -> Window a -> GraphvizGuiRef st b f -> OpenImageFn -> IO ()
createAndOpenImage cachedir f gvref openFn = do
let errormsg g = "The file " ++ g ++ " was not created!\n"
++ "Is graphviz installed?"
gvStatus <- createImage cachedir f gvref
case gvStatus of
GvCreated graphic ->
do exists <- doesFileExist graphic
if exists
then openFn graphic
else errorDialog f "" (errormsg graphic)
GvError err -> errorDialog f "" err
GvNoSuchItem _ -> return ()
GvCached -> return ()
-- | Creates a graphical visualisation for anything which can be displayed
-- by graphviz.
createImage :: (GraphvizShow f b)
=> FilePath -- ^ cache directory
-> Window a -- ^ parent window
-> GraphvizGuiRef st b f -- ^ stuff to display
-> IO GraphvizStatus
createImage cachedir f gvref = do
gvSt <- readIORef gvref
-- putStrLn $ "creating image via graphviz"
let drawables = gvitems gvSt
sel = gvsel gvSt
config = gvparams gvSt
dotFile <- createDotPath cachedir (show sel)
graphicFile <- createImagePath cachedir (show sel)
let create x = do toGraphviz config x dotFile graphicFile
return . GvCreated $ graphicFile
handler err = do errorDialog f "Error calling graphviz" (show err)
return . GvError . show $ err
exists <- doesFileExist graphicFile
-- we only call graphviz if the image is not in the cache
if exists
then return (GvCreated graphicFile)
else case Map.lookup sel drawables of
Nothing -> return . GvNoSuchItem $ sel
Just it -> create it `catch` handler
-- | Directory to dump image files in so that we can avoid regenerating them.
-- If the directory already exists, we can just delete all the files in it.
initCacheDir :: String -> IO()
initCacheDir cachesubdir = do
mainCacheDir <- gv_CACHEDIR
cmainExists <- doesDirectoryExist mainCacheDir
Monad.when (not cmainExists) $ createDirectory mainCacheDir
--
let cachedir = mainCacheDir </> cachesubdir
cExists <- doesDirectoryExist cachedir
if (cExists)
then do let notdot x = (x /= "." && x /= "..")
contents <- getDirectoryContents cachedir
olddir <- getCurrentDirectory
setCurrentDirectory cachedir
mapM removeFile $ filter notdot contents
setCurrentDirectory olddir
return ()
else createDirectory cachedir
-- ----------------------------------------------------------------------
-- Miscellaneous
-- ----------------------------------------------------------------------
-- | Save the given string to a file, if the user selets one via the file save
-- dialog. Otherwise, don't do anything.
maybeSaveAsFile :: (Window a) -> String -> IO ()
maybeSaveAsFile f msg =
do let filetypes = [("Any file",["*","*.*"])]
fsel <- fileSaveDialog f False True "Save to" filetypes "" ""
case fsel of
Nothing -> return ()
Just file -> writeFile file msg
-- | A message panel for use by the Results gui panels.
messageGui :: (Window a) -> String -> IO Layout
messageGui f msg = do
p <- panel f []
-- sw <- scrolledWindow p [scrollRate := sz 10 10 ]
t <- textCtrl p [ text := msg, enabled := False ]
return (fill $ container p $ column 1 $ [ fill $ widget t ])
gv_CACHEDIR :: IO String
gv_CACHEDIR = do
home <- getHomeDirectory
return $ home </> ".gvcache"
createImagePath :: String -> String -> IO String
createImagePath subdir name = do
cdir <- gv_CACHEDIR
return $ cdir </> subdir </> name <.> "png"
createDotPath :: String -> String -> IO String
createDotPath subdir name = do
cdir <- gv_CACHEDIR
return $ cdir </> subdir </> name <.> "dot"