module NLP.GenI.Gui (guiGeni) where
import Control.Applicative ((<$>))
import Control.Exception (SomeException, catch, try)
import Control.Monad (unless)
import Control.Monad.Trans.Except
import Data.IORef (modifyIORef, readIORef)
import Data.List (delete, findIndex, nub)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Version (showVersion)
import Prelude
import System.Directory
import System.Exit (ExitCode (ExitSuccess), exitWith)
import System.FilePath (makeRelative)
import Graphics.UI.WX
import Graphics.UI.WXCore
import NLP.GenI
import qualified NLP.GenI.Builder as B
import qualified NLP.GenI.BuilderGui as BG
import NLP.GenI.Configuration (Params (..), getBuilderType,
getRanking, mainBuilderTypes,
parseFlagWithParsec)
import NLP.GenI.Flag
import NLP.GenI.General (fst3, prettyException, trim)
import NLP.GenI.GeniShow
import NLP.GenI.GuiHelper
import NLP.GenI.LexicalSelection
import NLP.GenI.Parser hiding (choice, label, tab, try)
import NLP.GenI.Polarity
import NLP.GenI.Pretty
import NLP.GenI.Semantics
import NLP.GenI.Simple.SimpleGui
import NLP.GenI.TestSuite (TestCase (..))
import Paths_geni_gui (version)
guiGeni :: ProgStateRef -> CustomSem sem -> IO()
guiGeni pstRef wrangler = start (mainGui pstRef wrangler)
mainGui :: ProgStateRef -> CustomSem sem -> IO ()
mainGui pstRef wrangler = do
pst <- readIORef pstRef
f <- frame [text := "Geni Project"]
status <- statusField []
fileMen <- menuPane [text := "&File"]
loadMenIt <- menuItem fileMen [text := "&Open files or configure GenI"]
quitMenIt <- menuQuit fileMen [text := "&Quit"]
set quitMenIt [on command := close f ]
helpMen <- menuPane [text := "&Help"]
aboutMeIt <- menuAbout helpMen [help := "About"]
set f [ statusBar := [status]
, menuBar := [fileMen, helpMen]
, on (menu aboutMeIt) := infoDialog f "About GenI"
("The GenI generator " ++ showVersion version ++
".\nhttp://kowey.github.com/GenI" )
]
let hasSem = hasFlag TestSuiteFlg pst
testSuiteChoice <- choice f [ selection := 0, enabled := hasSem ]
tsTextBox <- textCtrl f [ wrap := WrapWord
, clientSize := sz 200 80
, enabled := hasSem
, text := "" ]
testCaseChoice <- choice f [ selection := 0
, enabled := hasSem ]
let initialDP = maybe "" showPolarityAttrs (getFlag DetectPolaritiesFlg pst)
initialRF = maybe "" prettyStr (getFlag RootFeatureFlg pst)
detectPolsTxt <- entry f [ text := initialDP ]
rootFeatTxt <- entry f [ text := initialRF ]
macrosFileLabel <- staticText f [ text := getListFlag MacrosFlg pst ]
lexiconFileLabel <- staticText f [ text := getListFlag LexiconFlg pst ]
let genfn = doGenerate f pstRef wrangler tsTextBox detectPolsTxt rootFeatTxt
pauseOnLexChk <- checkBox f [ text := "Inspect lex", tooltip := "Affects debugger only" ]
debugBt <- button f [ text := "Debug"
, on command := get pauseOnLexChk checked >>= genfn True ]
genBt <- button f [text := "Generate", on command := genfn False False ]
quitBt <- button f [ text := "Quit",
on command := close f]
let setBuilder b = modifyIORef pstRef . modifyParams
$ \p -> p { builderType = Just b }
initialSelection = case getBuilderType (pa pst) of
SimpleBuilder -> 0
SimpleOnePhaseBuilder -> 1
algoChoiceBox <- radioBox f Vertical (map show mainBuilderTypes) []
setSelection algoChoiceBox mainBuilderTypes initialSelection setBuilder
polChk <- optCheckBox f pstRef polarisedBio
guidedRealisationChk <- optCheckBox f pstRef guidedRealisationBio
useSemConstraintsChk <- optCheckBox f pstRef semConstraintBio
let myWidgets = MainWidgets
{ f = f
, macrosFileLabel = macrosFileLabel
, lexiconFileLabel = lexiconFileLabel
, testSuiteChoice = testSuiteChoice
, testCaseChoice = testCaseChoice
, tsTextBox = tsTextBox
}
onLoad = mainOnLoad pstRef wrangler myWidgets
set loadMenIt [ on command := configGui pstRef onLoad ]
onLoad
let labeledRow l w = row 1 [ label l, hfill (widget w) ]
let gramsemBox = boxed "Files last loaded" $
hfill $ column 1
[ labeledRow "trees:" macrosFileLabel
, labeledRow "lexicon:" lexiconFileLabel
]
optimBox =
column 5 [ label "Algorithm"
, dynamic $ widget algoChoiceBox
, label "Optimisations"
, dynamic $ widget polChk
, dynamic $ widget guidedRealisationChk
, dynamic $ widget useSemConstraintsChk
]
set f [layout := column 5 [ gramsemBox
, row 5 [ fill $
hfill $ column 5
[ labeledRow "test suite: " testSuiteChoice
, labeledRow "test case: " testCaseChoice
, fill $ widget tsTextBox
, row 1 [ label "detect pols: "
, hfill (widget detectPolsTxt)
, glue
, label "root feature: "
, hfill (widget rootFeatTxt)
]
]
, vfill optimBox ]
, row 1 [ widget quitBt
, hfloatRight $ row 5 [ widget pauseOnLexChk, widget debugBt, widget genBt ]] ]
, on closing := exitWith ExitSuccess
]
data MainWidgets = MainWidgets
{ f :: Frame ()
, macrosFileLabel :: StaticText ()
, lexiconFileLabel :: StaticText ()
, testSuiteChoice :: Choice ()
, testCaseChoice :: Choice ()
, tsTextBox :: TextCtrl ()
}
mainOnLoad :: ProgStateRef -> CustomSem sem -> MainWidgets -> IO ()
mainOnLoad pstRef wrangler (MainWidgets {..}) = do
pst <- readIORef pstRef
set macrosFileLabel [ text := getListFlag MacrosFlg pst ]
set lexiconFileLabel [ text := getListFlag LexiconFlg pst ]
case getListFlag TestInstructionsFlg pst of
[] -> do
set testSuiteChoice [ enabled := False, items := [] ]
set testCaseChoice [ enabled := False, items := [] ]
is -> do
set testSuiteChoice [ enabled := True, items := map fst is ]
setSelection testSuiteChoice is 0 $
\t -> loadTestSuiteAndRefresh f pstRef wrangler t (tsTextBox, testCaseChoice)
data OptType = Opti | Pessi
data OptBio = OptBio
{ odType :: OptType
, odOpt :: Optimisation
, odShortTxt :: String
, odToolTip :: String
}
polarisedBio :: OptBio
polarisedBio = OptBio Opti Polarised
"Polarities"
"Use the polarity optimisation"
semConstraintBio :: OptBio
semConstraintBio = OptBio Pessi NoConstraints
"Sem constraints"
"Use any sem constraints the user provides"
guidedRealisationBio :: OptBio
guidedRealisationBio = OptBio Opti Guided
"Guided realisation"
"Do tree assembly one polarity path at a time"
optBios :: [OptBio]
optBios = [ polarisedBio, guidedRealisationBio, semConstraintBio ]
optCheckBox :: Window a -> ProgStateRef -> OptBio -> IO (CheckBox ())
optCheckBox f pstRef od = do
pst <- readIORef pstRef
chk <- checkBox f [ checked := flippy (hasOpt o (flags pst))
, text := odShortTxt od
, tooltip := odToolTip od
]
set chk [ on command := onCheck chk ]
return chk
where
o = odOpt od
flippy = case odType od of
Opti -> id
Pessi -> not
onCheck chk = do
isChecked <- get chk checked
pst <- readIORef pstRef
let modopt = if flippy isChecked then (o:) else delete o
newopts = nub . modopt $ getListFlag OptimisationsFlg pst
modifyIORef pstRef . modifyParams $ setFlag OptimisationsFlg newopts
loadTestSuiteAndRefresh :: (Textual a, Selecting b, Selection b, Items b String)
=> Window w
-> ProgStateRef
-> CustomSem sem
-> Instruction
-> (a, b)
-> IO ()
loadTestSuiteAndRefresh f pstRef wrangler (suitePath,mcs) widgets = do
pst_ <- readIORef pstRef
let pst = setFlag TestSuiteFlg suitePath pst_
msuite <- try (loadTestSuite pst wrangler)
let mcase = getFlag TestCaseFlg pst
case msuite of
Left e -> errorDialog f ("Error reading test suite " ++ suitePath) $ show (e :: SomeException)
Right s -> onTestSuiteLoaded f wrangler s mcs mcase widgets
onTestSuiteLoaded :: (Textual a, Selecting b, Selection b, Items b String)
=> Window w
-> CustomSem sem
-> [TestCase sem]
-> Maybe [Text]
-> Maybe Text
-> (a, b)
-> IO ()
onTestSuiteLoaded f _ suite mcs mcase (tsBox, caseChoice) = do
let suiteCases = case filter (\c -> tcName c `elem` fromMaybe [] mcs) suite of
[] -> suite
res -> res
unless (null suiteCases) $ do
initial <- getInitialSelection mcase suiteCases
set caseChoice [ items := zipWith numfn [1..] suiteCases ]
setSelection caseChoice suiteCases initial setTsBox
where
numfn :: Int -> TestCase sem -> String
numfn n t = concat [ if hasName (fromMaybe "" mcase) t then "* " else ""
, show n
, ". "
, T.unpack (tcName t)
]
getInitialSelection Nothing _ = return 0
getInitialSelection (Just n) tcases =
case findIndex (hasName n) tcases of
Nothing -> do
errorDialog f "" ("No such test case: " ++ T.unpack n)
return 0
Just i -> return i
hasName name tc = tcName tc == name
setTsBox (TestCase {..}) =
set tsBox [ text := T.unpack tcSemString ]
configGui :: ProgStateRef -> IO () -> IO ()
configGui pstRef loadFn = do
pst <- readIORef pstRef
f <- frame []
p <- panel f []
nb <- notebook p []
let browseTxt = "Browse"
let fakeBoxed title lst = hstretch $ column 3 $ map hfill $
[ hrule 1 , alignRight $ label title, vspace 5 ]
++ map hfill lst
let longSize = sz 20 (25 :: Int)
pbas <- panel nb []
macrosFileLabel <- staticText pbas [ text := getListFlag MacrosFlg pst ]
lexiconFileLabel <- staticText pbas [ text := getListFlag LexiconFlg pst ]
tsFileLabel <- staticText pbas [ text := getListFlag TestSuiteFlg pst ]
macrosBrowseBt <- button pbas [ text := browseTxt ]
lexiconBrowseBt <- button pbas [ text := browseTxt ]
tsBrowseBt <- button pbas [ text := browseTxt ]
detectPolsTxt <- entry pbas
[ text := maybe "" showPolarityAttrs
(getFlag DetectPolaritiesFlg pst)
, size := longSize ]
rootFeatTxt <- entry pbas
[ text := maybe "" prettyStr (getFlag RootFeatureFlg pst)
, size := longSize ]
let layFiles = [ row 1 [ label "trees:"
, fill $ widget macrosFileLabel
, widget macrosBrowseBt ]
, row 1 [ label "lexicon:"
, fill $ widget lexiconFileLabel
, widget lexiconBrowseBt ]
, row 1 [ label "test suite:"
, fill $ widget tsFileLabel
, widget tsBrowseBt ]
, hspace 5
, hfill $ vrule 1
, row 3 [ label "detect polarities"
, hglue
, rigid $ widget detectPolsTxt ]
, row 3 [ label "root features"
, hglue
, rigid $ widget rootFeatTxt ]
]
let layBasic = dynamic $ container pbas $
hfloatLeft $ dynamic $ fill $ column 4 $ map (dynamic.hfill) layFiles
padv <- panel nb []
viewCmdTxt <- entry padv
[ tooltip := "Command used for XMG tree viewing"
, text := getListFlag ViewCmdFlg pst ]
let layXMG = fakeBoxed "XMG tools"
[ row 3 [ label "XMG view command"
, marginRight $ hfill $ widget viewCmdTxt ] ]
morphFileLabel <- staticText padv [ text := getListFlag MorphInfoFlg pst ]
morphFileBrowseBt <- button padv [ text := browseTxt ]
morphCmdTxt <- entry padv
[ tooltip := "Commmand used for morphological generation"
, text := getListFlag MorphCmdFlg pst ]
let layMorph = fakeBoxed "Morphology"
[ row 3 [ label "morph info:"
, expand $ hfill $ widget morphFileLabel
, widget morphFileBrowseBt ]
, row 3 [ label "morph command"
, (marginRight.hfill) $ widget morphCmdTxt ] ]
let layAdvanced = hfloatLeft $ container padv
$ column 10 [ layXMG, layMorph ]
curDir <- getCurrentDirectory
let onBrowse theLabel = do
rawFilename <- get theLabel text
let filename = makeRelative curDir rawFilename
filetypes = [("Any file",["*","*.*"])]
fsel <- fileOpenDialog f False True
"Choose your file..." filetypes "" filename
case fsel of
Nothing -> return ()
Just file -> set theLabel [ text := makeRelative curDir file ]
let setBrowse w l = set w [ on command := onBrowse l ]
setBrowse macrosBrowseBt macrosFileLabel
setBrowse lexiconBrowseBt lexiconFileLabel
setBrowse tsBrowseBt tsFileLabel
setBrowse morphFileBrowseBt morphFileLabel
let parseRF = parseFlagWithParsec "root features" geniFeats . T.pack
onLoad
= do macrosVal <- get macrosFileLabel text
lexconVal <- get lexiconFileLabel text
tsVal <- get tsFileLabel text
detectPolsVal <- get detectPolsTxt text
rootCatVal <- get rootFeatTxt text
viewVal <- get viewCmdTxt text
morphCmdVal <- get morphCmdTxt text
morphInfoVal <- get morphFileLabel text
let maybeSet fl fn x =
if null x then deleteFlag fl else setFlag fl (fn x)
maybeSetStr fl = maybeSet fl id
let setConfig = id
. maybeSetStr MacrosFlg macrosVal
. maybeSetStr LexiconFlg lexconVal
. maybeSetStr TestSuiteFlg tsVal
. maybeSetStr TestInstructionsFlg [(tsVal,Nothing)]
. setFlag DetectPolaritiesFlg (readPolarityAttrs detectPolsVal)
. maybeSet RootFeatureFlg parseRF rootCatVal
. maybeSetStr ViewCmdFlg viewVal
. maybeSetStr MorphCmdFlg morphCmdVal
. maybeSetStr MorphInfoFlg morphInfoVal
modifyIORef pstRef (modifyParams setConfig)
loadFn
cancelBt <- button p [ text := "Cancel", on command := close f ]
loadBt <- button p [ text := "Load", on command := do { onLoad; close f } ]
set f [ layout := dynamic $ fill $ container p $ column 0
[ fill $ tabs nb [ tab "Basic" layBasic
, tab "Advanced" layAdvanced ]
, hfill $ row 1 [ hfloatLeft (widget cancelBt)
, hfloatRight (widget loadBt) ]
]
]
doGenerate :: Textual tb => Window a -> ProgStateRef
-> CustomSem sem
-> tb
-> tb
-> tb
-> Bool -> Bool -> IO ()
doGenerate f pstRef wrangler sembox detectPolsTxt rootFeatTxt useDebugger pauseOnLex = do
let parseRF = parseFlagWithParsec "root features" geniFeats . T.pack
rootCatVal <- get rootFeatTxt text
detectPolsVal <- get detectPolsTxt text
let maybeSet fl fn x =
if null x then deleteFlag fl else setFlag fl (fn x)
let setConfig = id
. maybeSet RootFeatureFlg parseRF rootCatVal
. setFlag DetectPolaritiesFlg (readPolarityAttrs detectPolsVal)
modifyIORef pstRef (modifyParams setConfig)
minput <- do
set sembox [ text :~ trim ]
loadEverything pstRef wrangler
customSemParser wrangler . unautocorrect . T.pack <$> get sembox text
case minput of
Left e -> errorDialog f "Please give me better input" (show e)
Right semInput -> do
pst <- readIORef pstRef
let doDebugger bg = debugGui bg pst wrangler semInput pauseOnLex
doResults bg = resultsGui bg pst wrangler semInput
catch
(withBuilderGui $ if useDebugger then doDebugger else doResults)
(handler "Error during realisation" prettyException)
where
handler title fn err = errorDialog f title (fn err)
withBuilderGui a = do
pst <- readIORef pstRef
case getBuilderType (pa pst) of
SimpleBuilder -> a simpleGui2p
SimpleOnePhaseBuilder -> a simpleGui1p
unautocorrect = T.replace "©" "(C)"
resultsGui :: BG.BuilderGui -> ProgState -> CustomSem sem -> TestCase sem -> IO ()
resultsGui builderGui pst wrangler semInput = do
f <- frame [ text := "Results"
, fullRepaintOnResize := False
, layout := stretch $ label "Generating..."
, clientSize := sz 300 300
]
p <- panel f []
nb <- notebook p []
inputTab <- inputInfoGui nb (geniFlags (pa pst)) wrangler semInput
(results,_,summTab,resTab) <- BG.resultsPnl builderGui pst wrangler nb semInput
mRankTab <- if null (getRanking (pa pst))
then return Nothing
else Just <$> messageGui nb (purty results)
let myTabs = catMaybes
[ Just (tab "summary" summTab)
, Just (tab "realisations" resTab)
, tab "ranking" <$> mRankTab
, Just (tab "input" inputTab)
]
set f [ layout := container p $ column 0 [ tabs nb myTabs ]
, clientSize := bigSize ]
repaint f
return ()
where
purty res = T.unlines $ map (prettyResult pst) [ x | GSuccess x <- res ]
inputInfoGui :: Window a
-> [Flag]
-> CustomSem sem
-> TestCase sem
-> IO Layout
inputInfoGui f flags_ wrangler tc = messageGui f . T.unlines $
[ csemStr, "" ] ++ semBlock ++
[ "Options"
, "-------"
, "Root feature: " <> maybe "" pretty (getFlag RootFeatureFlg flags_)
, ""
, "Optimisations"
, "-------------"
] ++ map optStatus optBios ++ polStuff
where
csemStr = customRenderSem wrangler (tcSem tc)
semBlock = case fromCustomSemInput wrangler (tcSem tc) of
Left err -> [ "SEMANTIC CONVERSION ERROR"
, "-------------------------"
, err
, ""
]
Right sem ->
if pretty sem == csemStr
then []
else [ "Converted to semantics"
, "----------------------"
, displaySemInput (squeezed 50 . map geniShowText) sem
, ""
]
optStatus od = T.pack (odShortTxt od) <> ": " <>
if enabld od then "Yes" else "No"
enabld od = case odType od of
Opti -> configged od
Pessi -> not (configged od)
configged od = hasOpt (odOpt od) flags_
dps = maybe "" showPolarityAttrs (getFlag DetectPolaritiesFlg flags_)
polStuff = if enabld polarisedBio
then [ ""
, "Detect polarities: " <> T.pack dps
]
else []
debugGui :: BG.BuilderGui -> ProgState -> CustomSem sem -> TestCase sem -> Bool -> IO ()
debugGui builderGui pst wrangler tc pauseOnLex = do
f <- frame [ text := "GenI Debugger - " ++ show btype ++ " edition"
, fullRepaintOnResize := False
, clientSize := sz 300 300
]
p <- panel f []
nb <- notebook p []
let addTabs [] = return ()
addTabs ts = do
oldCount <- notebookGetPageCount nb
set f [ layout := container p (tabs nb ts)
, clientSize := bigSize
]
notebookSetSelection nb oldCount >> return ()
minit <- runExceptT $ initGeni pst wrangler (tcSem tc)
case minit of
Left err -> do
msgPnl <- messageGui nb (T.pack err)
addTabs [ tab "error" msgPnl ]
Right x -> guiRest nb addTabs x (tcParams tc)
where
btype = getBuilderType (pa pst)
myPolarityGui nb autstuff =
fst3 <$> polarityGui nb (prIntermediate autstuff) (prFinal autstuff)
noBv x = (x, emptyPolPaths)
guiRest nb addTabs (initStuff, initWarns) newPa = do
let (cand,_) = unzip $ B.inCands initStuff
let step3 results stats = do
resPnl <- BG.summaryPnl builderGui pst nb results stats
addTabs [tab "summary" resPnl]
let step2 newCands = do
let newInitStuff = initStuff { B.inCands = map noBv newCands }
(input2, autstuff) = B.preInit newInitStuff (flags pst)
mAutPnl <- if hasOpt Polarised (flags pst)
then Just <$> myPolarityGui nb autstuff
else return Nothing
debugPnl <- BG.debuggerPnl builderGui pst newPa nb input2 (show btype) step3
let mAutTab = tab "automata" <$> mAutPnl
debugTab = tab "tree assembly" debugPnl
addTabs $ catMaybes [ mAutTab, Just debugTab ]
inpPnl <- inputInfoGui nb (flags pst) wrangler tc
(canPnl,_,_) <- pauseOnLexGui (pa pst) nb
(B.inLex initStuff) cand initWarns $
if pauseOnLex then Just step2 else Nothing
addTabs [ tab "input" inpPnl
, tab "lexical selection" canPnl
]
unless pauseOnLex (step2 cand)
bigSize :: Size2D Int
bigSize = sz 700 600
modifyParams :: (Params -> Params) -> ProgState -> ProgState
modifyParams f pst = pst { pa = f (pa pst) }