module NLP.GenI.GuiHelper where
import Control.Applicative ((<$>))
import Control.Exception hiding (bracket)
import Control.Monad (forM_, unless)
import qualified Control.Monad as Monad
import Control.Monad.State.Strict (execStateT, runState)
import Data.Array (listArray, (!))
import Data.IORef
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Prelude
import System.Directory
import System.FilePath (dropExtensions, (<.>), (</>))
import System.Process (runProcess)
import Data.GraphViz.Exception (GraphvizException (..))
import Graphics.UI.WX
import Graphics.UI.WXCore (textCtrlSetEditable)
import NLP.GenI
import NLP.GenI.Automaton (numStates, numTransitions)
import NLP.GenI.Builder (chart_size, num_comparisons,
num_iterations, queryCounter)
import qualified NLP.GenI.Builder as B
import NLP.GenI.Configuration (Params (..))
import NLP.GenI.Flag
import NLP.GenI.General (dropTillIncluding, ePutStrLn)
import NLP.GenI.GeniShow (geniShowText)
import NLP.GenI.Graphviz
import NLP.GenI.GraphvizShow
import NLP.GenI.GraphvizShowPolarity ()
import NLP.GenI.Lexicon
import NLP.GenI.Parser (geniTagElems, parseFromFile)
import NLP.GenI.Polarity (AutDebug, PolAut,
suggestPolFeatures)
import NLP.GenI.Pretty
import NLP.GenI.Statistics
import NLP.GenI.Tag (TagElem (ttrace, tinterface),
TagItem (tgIdName), idname,
mapBySem, tagLeaves)
import NLP.GenI.TreeSchema (showLexeme)
import NLP.GenI.Warning
data GraphvizStatus = GvError String
| GvNoSuchItem Int
| GvCached
| GvCreated FilePath
deriving Show
pauseOnLexGui :: Params
-> Window a
-> [LexEntry]
-> [TagElem]
-> GeniWarnings
-> Maybe ([TagElem] -> IO ())
-> GvIO () (GvItem Bool TagElem)
pauseOnLexGui config f lexs xs warns mjob = do
p <- panel f []
candV <- varCreate xs
(tb, ref, updater) <- candidateGui config p xs warns
let dispCmd = T.putStrLn (geniShowText lexs)
saveCmd = do
cs <- varGet candV
maybeSaveAsFile f (geniShowText cs <> "\n")
loadCmd = loadLex $ \cs -> do
varSet candV cs
setGvDrawables ref (sectionsBySem cs)
updater
dispBt <- button p [ text := "Show lexical entries", on command := dispCmd ]
saveBt <- button p [ text := "Save selection", on command := saveCmd ]
loadBt <- button p [ text := "Load", on command := loadCmd ]
nextBt <- button p [ text := "Begin" ]
let disableBar = forM_ [ loadBt, nextBt ] $
\w -> set w [ enabled := False ]
continue job = do
disableBar
varGet candV >>= job
case mjob of
Nothing -> disableBar
Just j -> set nextBt [ on command := continue j ]
let lay = fill $ container p $ column 5
[ fill tb, hfill (vrule 1)
, row 0 [ row 5 [ widget dispBt, widget saveBt, widget loadBt ]
, hfloatRight $ widget nextBt ] ]
return (lay, ref, updater)
where
loadLex job = do
fsel <- fileOpenDialog f False True
"Choose your file..."
anyFile "" ""
flip maybeIO fsel $ \file -> do
parsed <- parseFromFile geniTagElems file
case parsed of
Left err -> errorDialog f "" (show err)
Right c -> job c
candidateGui :: Params
-> Window a
-> [TagElem]
-> GeniWarnings
-> GvIO () (GvItem Bool TagElem)
candidateGui config f xs warns = do
pouter <- panel f []
split <- splitterWindow pouter []
p <- panel split []
(tb,gvRef,updater) <- tagViewerGui config p "lexically selected item" "candidates"
$ sectionsBySem xs
let polFeats = "Polarity attributes detected:" <+>
case suggestPolFeatures xs of
[] -> "None! :-("
fs -> T.unwords fs
addPolFeats fs = if hasOpt Polarised (geniFlags config)
then polFeats : fs
else fs
lexWarnings = concatMap showGeniWarning . fromGeniWarnings . sortWarnings $ warns
warning = T.unlines $ filter (not . T.null) (addPolFeats lexWarnings)
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 ]
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 ]
let updateTrace = gvOnSelect (return ())
(\s -> set traceLst [ items := map T.unpack $ ttrace s ])
updateIface = gvOnSelect (return ())
(\s -> set ifaceLst [ items := map prettyStr $ tinterface s ])
Monad.unless (null xs) $ do
addGvHandler gvRef updateTrace
addGvHandler gvRef updateIface
gvSt <- readIORef gvRef
updateIface gvSt
updateTrace gvSt
let layMain = fill $ row 2 [ fill tb, vfill laySide ]
warningTxt <- textCtrl split [ text := T.unpack warning ]
let lay = fill . container pouter
$ fill $ hsplit split 5 100 (widget warningTxt) (container p layMain)
return (lay, gvRef, updater)
sectionsBySem :: (TagItem t) => [t] -> [GvItem Bool t]
sectionsBySem tsem =
concatMap section sem
where
semmap = mapBySem tsem
sem = Map.keys semmap
lookupTr k = Map.findWithDefault [] k semmap
section k = GvHeader header : map tlab (lookupTr k)
where
header = "___" <> pretty k <> "___"
tlab t = GvItem (tgIdName t) False t
polarityGui :: Window a
-> [AutDebug]
-> PolAut
-> GvIO () (GvItem () PolAut)
polarityGui f xs final = do
gvRef <- newGvRef () "automata"
setGvDrawables gvRef $ concatMap toItem xs ++ [finalItem]
graphvizGui f "polarity" gvRef
where
toItem (pkey, a1, a2) = [ it (pretty pkey) a1
, it (pretty pkey <+> "pruned") a2 ]
finalItem = it "final" final
it n a = GvItem (lab n a) () a
lab n a = (n <+>) $ parens $
pretty (numStates a) <> "st " <>
pretty (numTransitions a) <> "tr"
class XMGDerivation a where
getSourceTrees :: a -> [Text]
instance XMGDerivation TagElem where
getSourceTrees te = [idname te]
toSentence :: TagElem -> Text
toSentence = T.unwords . map squishLeaf . tagLeaves
squishLeaf :: (a,([Text], b)) -> Text
squishLeaf = showLexeme . fst . snd
tagViewerGui :: (GraphvizShow (GvItem Bool t), XMGDerivation t)
=> Params
-> Window a
-> Text
-> FilePath
-> [GvItem Bool t]
-> GvIO () (GvItem Bool t)
tagViewerGui config f tip cachedir itNlab = do
p <- panel f []
gvRef <- newGvRef () tip
setGvDrawables gvRef itNlab
(lay,ref,onUpdate) <- graphvizGui p cachedir gvRef
detailsChk <- checkBox p [ text := "Show features"
, checked := False ]
viewTagLay <- viewTagWidgets p gvRef config
let onDetailsChk = do
isDetailed <- get detailsChk checked
modifyGvItems gvRef (gvItemSetFlag isDetailed)
onUpdate
set detailsChk [ on command := onDetailsChk ]
let cmdBar = hfill $ row 5 [ dynamic $ widget detailsChk, viewTagLay ]
lay2 = fill $ container p $ column 5 [ fill lay, cmdBar ]
return (lay2,ref,onUpdate)
viewTagWidgets :: (XMGDerivation t)
=> Window a
-> GraphvizGuiRef st (GvItem Bool t)
-> Params
-> IO Layout
viewTagWidgets p gvRef config = do
viewTagBtn <- button p [ text := "ViewTAG" ]
viewTagCom <- choice p [ tooltip := "derivation tree" ]
let onViewTag d = readIORef gvRef >>=
gvOnSelect (return ()) (const (runViewTag config (T.unpack d)))
let updateDerivationList = gvOnSelect
(set viewTagCom [ enabled := False ])
(\s -> do
let dervs = getSourceTrees s
set viewTagCom [ enabled := True
, items := map T.unpack dervs
]
setSelection viewTagCom dervs 0 $ \d ->
set viewTagBtn [ on command := onViewTag d ]
)
addGvHandler gvRef updateDerivationList
updateDerivationList =<< readIORef gvRef
return $ row 5 $ map dynamic [ widget viewTagCom, widget viewTagBtn ]
runViewTag :: Params -> String -> IO ()
runViewTag params drName =
maybeOrWarn warnTf (getFlag MacrosFlg params) $ \f ->
maybeOrWarn warnVc (getFlag ViewCmdFlg params) $ \cmd ->
actuallyView f cmd
where
warnTf = "Warning: No tree schema file specified (runViewTag)"
warnVc = "Warning: No viewcmd specified (runViewTag)"
treenameOnly = takeWhile (/= ':')
. dropTillIncluding ':' . dropTillIncluding ':'
actuallyView f cmd =
runProcess cmd [ dropExtensions f <.> "rec", treenameOnly drName]
Nothing Nothing Nothing Nothing Nothing >> return ()
type DebuggerItemBar st flg itm =
Panel ()
-> GraphvizGuiRef st (GvItem flg itm)
-> GvUpdater
-> IO (Layout, GvUpdater)
data GraphvizShow (GvItem flg itm) => Debugger st flg itm = Debugger
{ dBuilder :: B.Builder st itm
, dToGv :: st -> [GvItem flg itm]
, dControlPnl :: DebuggerItemBar st flg itm
, dCacheDir :: FilePath
, dNext :: [GeniResult] -> Statistics -> IO ()
}
debuggerPanel :: GraphvizShow (GvItem flg itm)
=> Debugger st flg itm
-> ProgState
-> Window a
-> B.Input
-> Maybe Params
-> IO Layout
debuggerPanel (Debugger {..}) pst f input newPa = do
let config = setMetrics pst
let (initS, initStats) = initBuilder input (flags config)
p <- panel f []
gvRef <- newGvRef initS "debugger session"
setGvDrawables gvRef (dToGv initS)
(layItemViewer,_,onUpdateMain) <- graphvizGui p dCacheDir gvRef
(layItemBar,onUpdateItemBar) <- dControlPnl p gvRef onUpdateMain
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 []
done <- varCreate False
let showQuery c gs = maybe "???" show (queryCounter c gs)
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 (dToGv s2)
setGvSel gvRef 1
onUpdate
updateStatsTxt stats2
set nextBt [ on command :~ (\_ -> showNext (s2,stats2) ) ]
case B.finished dBuilder s2 of
B.Active -> return ()
_ -> callNext done stats2 s2
let showLast = do
let (s2, stats2) = runState (execStateT allSteps initS) initStats
setGvDrawables gvRef (dToGv s2)
onUpdate
updateStatsTxt stats2
callNext done stats2 s2
let showReset = do
set nextBt [ on command := showNext (initS, initStats) ]
updateStatsTxt initStats
setGvDrawables gvRef (dToGv initS)
setGvSel gvRef 1
onUpdate
set finishBt [ on command := showLast ]
set restartBt [ on command := showReset ]
showReset
let layCmdBar = hfill $ container db $ row 5
[ widget statsTxt, hfloatRight $ row 5
[ widget restartBt, widget nextBt
, widget leapVal, label " step(s)"
, widget finishBt ] ]
return $ fill $ container p $ column 5 [ layItemViewer, layItemBar, hfill (vrule 1), layCmdBar ]
where
initBuilder = B.init dBuilder
nextStep = B.step dBuilder
allSteps = B.stepAll dBuilder
setMetrics = setFlag MetricsFlg B.defaultMetricNames
callNext d stats st = do
done <- varGet d
unless done $ do
varSet d True
results <- extractResults pst newPa dBuilder st
dNext results stats
data GraphvizOrder = GvoParams | GvoItems | GvoSel
deriving Eq
data GraphvizGuiSt st a = GvSt
{ gvcore :: st
, gvitems :: Map.Map Int a
, gvlabels :: [Text]
, gvtip :: Text
, gvhandler :: Maybe (GraphvizGuiSt st a -> IO ())
, gvsel :: Int
, gvorders :: [GraphvizOrder]
}
type GraphvizGuiRef st a = IORef (GraphvizGuiSt st a)
newGvRef :: st -> Text -> IO (GraphvizGuiRef st a)
newGvRef initSt t = newIORef GvSt
{ gvcore = initSt
, gvitems = Map.empty
, gvlabels = []
, gvhandler = Nothing
, gvtip = t
, gvsel = 0
, gvorders = []
}
setGvSel :: GraphvizGuiRef st a -> Int -> IO ()
setGvSel gvref s = modifyIORef gvref $ \x ->
x { gvsel = s, gvorders = GvoSel : gvorders x }
modifyGvItems :: GraphvizGuiRef st a -> (a -> a) -> IO ()
modifyGvItems gvref fn =
modifyIORef gvref $ \s -> s { gvitems = Map.map fn (gvitems s) }
setGvDrawables :: GraphvizGuiRef st (GvItem f a) -> [GvItem f a] -> IO ()
setGvDrawables gvref itlb = modifyIORef gvref $ \x ->
x { gvitems = Map.fromList $ zip [0..] itlb
, gvlabels = map gvItemLabel itlb
, gvorders = GvoItems : gvorders x
}
gvOnSelect :: IO () -> (a -> IO ()) -> GraphvizGuiSt st (GvItem f a) -> IO ()
gvOnSelect onNothing onJust gvSt =
case Map.lookup sel things of
Just (GvItem _ _ s) -> onJust s
_ -> onNothing
where
sel = gvsel gvSt
things = gvitems gvSt
setGvHandler :: GraphvizGuiRef st a -> Maybe (GraphvizGuiSt st a -> IO ()) -> IO ()
setGvHandler gvref mh = do
gvSt <- readIORef gvref
modifyIORef gvref (\x -> x { gvhandler = mh })
maybeIO ($ gvSt) mh
addGvHandler :: GraphvizGuiRef st a -> (GraphvizGuiSt st a -> IO ()) -> IO ()
addGvHandler gvref h = do
gvSt <- readIORef gvref
let newH = case gvhandler gvSt of
Nothing -> h
Just oldH -> \g -> oldH g >> h g
setGvHandler gvref (Just newH)
type GvIO st d = IO (Layout, GraphvizGuiRef st d, GvUpdater)
type GvUpdater = IO ()
graphvizGui :: GraphvizShow d => Window a -> String -> GraphvizGuiRef st d -> GvIO st d
graphvizGui f cachedir gvRef = do
initGvSt <- readIORef gvRef
p <- panel f [ fullRepaintOnResize := False ]
split <- splitterWindow p []
(dtBitmap,sw) <- scrolledBitmap split
rchoice <- singleListBox split [ tooltip := T.unpack (gvtip initGvSt) ]
let openFn = openImage sw dtBitmap
let lay = fill $ container p $ margin 1 $ fill $
vsplit split 5 200 (widget rchoice) (widget sw)
set p [ on closing := closeImage dtBitmap ]
let withoutSelector job =
bracket ( swap rchoice (on select) (return ()) )
( \fn -> set rchoice [ on select := fn ] )
( const job )
let onUpdate = withoutSelector $ do
gvSt <- readIORef gvRef
let orders = gvorders gvSt
initCacheDir cachedir
Monad.when (GvoItems `elem` orders) $
set rchoice [ items := map T.unpack (gvlabels gvSt) ]
Monad.when (GvoSel `elem` orders) $
set rchoice [ selection := gvsel gvSt ]
modifyIORef gvRef (\x -> x { gvorders = []})
createAndOpenImage cachedir p gvRef openFn
let selectAndShow = do
sel <- get rchoice selection
modifyIORef gvRef (\x -> x { gvsel = sel })
gvSt <- readIORef gvRef
maybeIO ($ gvSt) (gvhandler gvSt)
onUpdate
set rchoice [ on select := selectAndShow ]
setGvSel gvRef 1
onUpdate
return (lay, gvRef, onUpdate)
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
bm <- bitmapCreateFromFile fname
closeImage vbitmap
set vbitmap [value := Just bm]
bmsize <- get bm size
set sw [virtualSize := bmsize]
repaint sw
closeImage :: VarBitmap -> IO ()
closeImage vbitmap =
maybeIO objectDelete =<< swap vbitmap value Nothing
onPaint :: VarBitmap -> DC a -> b -> IO ()
onPaint vbitmap dc _ =
maybeIO draw =<< get vbitmap value
where
draw bm = dcClear dc >> drawBitmap dc bm pointZero False []
createAndOpenImage :: GraphvizShow b
=> FilePath
-> Window a
-> GraphvizGuiRef st b
-> OpenImageFn
-> IO ()
createAndOpenImage cachedir f gvref openFn = do
gvStatus <- createImage cachedir f gvref
case gvStatus of
GvCreated g -> openGraphic g
GvNoSuchItem _ -> return ()
GvError err -> errorDialog f "" err
GvCached -> return ()
where
openGraphic graphic = do
exists <- doesFileExist graphic
if exists
then openFn graphic
else errorDialog f "" (noFile graphic)
noFile g = "The file " ++ g ++ " was not created! Is graphviz installed?"
createImage :: GraphvizShow b
=> FilePath
-> Window a
-> GraphvizGuiRef st b
-> IO GraphvizStatus
createImage cachedir f gvref = do
gvSt <- readIORef gvref
let drawables = gvitems gvSt
sel = gvsel gvSt
dotFile <- createDotPath cachedir (show sel)
graphicFile <- createImagePath cachedir (show sel)
let create x = do _ <- toGraphviz x dotFile graphicFile
return . GvCreated $ graphicFile
handler :: GraphvizException -> IO GraphvizStatus
handler err = do
errorDialog f "Error calling graphviz. Is it installed?" (show err)
return . GvError . show $ err
exists <- doesFileExist graphicFile
if exists
then return (GvCreated graphicFile)
else case Map.lookup sel drawables of
Nothing -> return (GvNoSuchItem sel)
Just it -> create it `catch` handler
initCacheDir :: String -> IO()
initCacheDir cachesubdir = do
mainCacheDir <- gvCACHEDIR
cmainExists <- doesDirectoryExist mainCacheDir
unless cmainExists $ createDirectory mainCacheDir
let cachedir = mainCacheDir </> cachesubdir
cExists <- doesDirectoryExist cachedir
if cExists
then do
contents <- filter notJunk <$> getDirectoryContents cachedir
mapM_ (removeFile . (cachedir </>)) contents
else createDirectory cachedir
where
notJunk = (`notElem` [".", ".."])
setSelection :: (Selecting w, Selection w)
=> w
-> [a]
-> Int
-> (a -> IO ())
-> IO ()
setSelection widgt xs initial reactor = do
set widgt [ selection := initial
, on select := onSelection ]
onSelection
where
imap = listArray (0, length xs 1) xs
onSelection = do
sel <- get widgt selection
reactor (imap ! sel)
maybeSaveAsFile :: Window a -> Text -> IO ()
maybeSaveAsFile f msg = do
fsel <- fileSaveDialog f False True "Save to" anyFile "" ""
case fsel of
Nothing -> return ()
Just file -> T.writeFile file msg
messageGui :: Window a -> Text -> IO Layout
messageGui f msg = do
p <- panel f []
t <- textCtrl p [ text := T.unpack msg ]
textCtrlSetEditable t False
return $ fill $ container p $ column 1 [ fill (widget t) ]
gvCACHEDIR :: IO String
gvCACHEDIR = do
home <- getHomeDirectory
return (home </> ".gvcache")
createImagePath :: String -> String -> IO String
createImagePath subdir name = do
cdir <- gvCACHEDIR
return (cdir </> subdir </> name <.> "png")
createDotPath :: String -> String -> IO String
createDotPath subdir name = do
cdir <- gvCACHEDIR
return (cdir </> subdir </> name <.> "dot")
maybeOrWarn :: String
-> Maybe a
-> (a -> IO ())
-> IO ()
maybeOrWarn warning m job = maybe (ePutStrLn warning) job m
maybeIO :: (a -> IO ()) -> Maybe a -> IO ()
maybeIO = maybe (return ())
anyFile :: [ (String,[String]) ]
anyFile = [("Any file",["*","*.*"])]