-- 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 FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module NLP.GenI.Simple.SimpleGui where import Control.Applicative ((<$>)) import Control.Arrow ((***)) import Control.Monad.Trans.Except import Data.IORef import Data.List (partition, sort) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.GraphViz as GV import qualified Data.GraphViz.Attributes.Complete as GV import Graphics.UI.WX import NLP.GenI import qualified NLP.GenI.Builder as B import qualified NLP.GenI.BuilderGui as BG import NLP.GenI.Configuration (Params (..)) import NLP.GenI.FeatureStructure (AvPair (..)) import NLP.GenI.General (buckets, snd3) import NLP.GenI.GeniVal (GeniVal, mkGConstNone) import NLP.GenI.Graphviz (GraphvizShow (..), gvUnlines) import NLP.GenI.GraphvizShow (GNodeHighlights, GvItem (..), Highlights, graphvizShowDerivation, gvItemSetFlag) import NLP.GenI.GuiHelper (Debugger (..), DebuggerItemBar, GraphvizGuiSt (..), GvIO, XMGDerivation (getSourceTrees), debuggerPanel, maybeSaveAsFile, messageGui, modifyGvItems, newGvRef, tagViewerGui, viewTagWidgets) import NLP.GenI.LexicalSelection (CustomSem (..)) import NLP.GenI.Morphology (LemmaPlus (..)) import NLP.GenI.Polarity hiding (finalSt) import NLP.GenI.Pretty import NLP.GenI.Simple.SimpleBuilder (SimpleGuiItem (..), SimpleItem (..), SimpleStatus, simpleBuilder, step, theAgenda, theChart, theHoldingPen, theResults, theTrash, unpackResult) import NLP.GenI.Statistics (Statistics, emptyStats, showFinalStats) import NLP.GenI.Tag (TagItem (..), dsChild) import NLP.GenI.TestSuite import NLP.GenI.TreeSchema (AdjunctionConstraint(..), GNode (..), GType (..)) -- -------------------------------------------------------------------- -- Interface -- -------------------------------------------------------------------- simpleGui2p, simpleGui1p :: BG.BuilderGui simpleGui2p = simpleGui True simpleGui1p = simpleGui False simpleGui :: Bool -> BG.BuilderGui simpleGui twophase = BG.BuilderGui { BG.resultsPnl = resultsPnl twophase , BG.summaryPnl = summaryGui , BG.debuggerPnl = simpleDebuggerTab twophase } resultsPnl :: Bool -> ProgState -> CustomSem sem -> Window a -> TestCase sem -> IO ([GeniResult], Statistics, Layout, Layout) resultsPnl twophase pst wrangler f tc = do mresults <- runExceptT $ runGeni pst wrangler (simpleBuilder twophase) tc case mresults of Left err -> do (resultsL, _, _) <- realisationsGui pst f [] summaryL <- messageGui f (T.pack err) return ([], emptyStats, summaryL, resultsL) Right (gresults, finalSt) -> do let sentences = grResults gresults stats = grStatistics gresults (resultsL, _, _) <- realisationsGui pst f $ theResults finalSt summaryL <- summaryGui pst f sentences stats return (sentences, stats, summaryL, resultsL) -- -------------------------------------------------------------------- -- Results -- -------------------------------------------------------------------- -- Derived Trees -- | Browser for derived/derivation trees, except if there are no results, we show a -- message box realisationsGui :: ProgState -> Window a -> [SimpleItem] -> GvIO () (GvItem Bool SimpleItem) realisationsGui _ f [] = do m <- messageGui f "No results found" g <- newGvRef () "" return (m, g, return ()) realisationsGui pst f resultsRaw = do tagViewerGui config f tip "derived" itNlabl where config = pa pst tip = "result" mkItNLabl x = GvItem (siToSentence x) False x itNlabl = map mkItNLabl resultsRaw summaryGui :: ProgState -> Window a -> [GeniResult] -> Statistics -> IO Layout summaryGui _ f results stats = do p <- panel f [] statsTxt <- textCtrl p [ text := showFinalStats stats ] t <- textCtrl p [ text := T.unpack msg ] saveBt <- button p [ text := "Save to file" , on command := maybeSaveAsFile f msg ] return $ fill $ container p $ column 1 [ hfill $ label "Performance data" , hfill $ widget statsTxt , hfill $ label $ "Realisations (" ++ show totalResults ++ " found)" , fill $ widget t , hfloatRight $ widget saveBt ] where (succeses, errors) = partitionGeniResult results taggedResults = concatMap sentences succeses resultBuckets = buckets snd taggedResults sentences x = map (\r -> (grOrigin x, r)) (grRealisations x) prettyBucket (s, xys) = s <+> parens instances where instances = if length ys == 1 then ys_str else pretty (length ys) <+> "instances:" <+> ys_str ys = map fst xys ys_str = T.intercalate ", " . map pretty . sort $ ys msg = T.unlines $ concatMap fromError errors ++ (if null succeses then [ "(none)" ] else map prettyBucket resultBuckets) totalResults = length taggedResults fromError (GeniError e) = e partitionGeniResult :: [GeniResult] -> ([GeniSuccess],[GeniError]) partitionGeniResult results = (map unSucc *** map unErr) $ partition isSuccess results where unSucc (GSuccess x) = x unSucc _ = error "NLP.GenI.Simple.SimpleGui unSucc" unErr (GError x) = x unErr _ = error "NLP.GenI.Simple.SimpleGui unErr" -- -------------------------------------------------------------------- -- Debugger -- -------------------------------------------------------------------- simpleDebuggerTab :: Bool -> ProgState -> Maybe Params -> Window a -> B.Input -> String -> ([GeniResult] -> Statistics -> IO ()) -> IO Layout simpleDebuggerTab twophase pst newPa f input name job = do debuggerPanel dbg pst f input newPa where dbg :: Debugger SimpleStatus Bool SimpleItem dbg = Debugger { dBuilder = simpleBuilder twophase , dToGv = stToGraphviz , dControlPnl = simpleItemBar (pa pst) , dNext = job , dCacheDir = name } stToGraphviz :: SimpleStatus -> [GvItem Bool SimpleItem] stToGraphviz st = concat [ agenda, auxAgenda, chart, trash, results ] where agenda = section "AGENDA" $ theAgenda st auxAgenda = section "HOLDING" $ theHoldingPen st trash = section "TRASH" $ theTrash st chart = section "CHART" $ theChart st results = section "RESULTS" $ theResults st -- section n i = hd : map tlFn i where hd = GvHeader ("___" <> n <> "___") tlFn x = GvItem (siToSentence x <+> prettyPaths x) False x prettyPaths = parens . prettyPolPaths . siPolpaths simpleItemBar :: Params -> DebuggerItemBar SimpleStatus Bool SimpleItem simpleItemBar config f gvRef updaterFn = do ib <- panel f [] phaseTxt <- staticText ib [ text := "" ] detailsChk <- checkBox ib [ text := "Show features" , checked := False ] viewTagLay <- viewTagWidgets ib gvRef config -- handlers let onDetailsChk = do isDetailed <- get detailsChk checked modifyGvItems gvRef (gvItemSetFlag isDetailed) updaterFn set detailsChk [ on command := onDetailsChk ] -- let lay = hfloatCentre . container ib . row 5 $ [ hspace 5 , widget phaseTxt , hglue , widget detailsChk , hglue , viewTagLay , hspace 5 ] let onUpdate = do status <- gvcore `fmap` readIORef gvRef set phaseTxt [ text := show (step status) ] onDetailsChk -- toggle the show features state return (lay, onUpdate) -- -------------------------------------------------------------------- -- Miscellaneous -- ------------------------------------------------------------------- -- to have the basic GraphvizShow functionality newtype SimpleItemWrapper = SimpleItemWrapper { fromSimpleItemWrapper :: SimpleItem } instance TagItem SimpleItemWrapper where tgIdName = siIdname . siGuiStuff . fromSimpleItemWrapper tgIdNum = siId . fromSimpleItemWrapper tgSemantics = siFullSem . siGuiStuff . fromSimpleItemWrapper tgTree si = lookupOrBug <$> siDerived (fromSimpleItemWrapper si) where lookupOrBug k = fromMaybe (buggyNode k) $ Map.lookup k nodeMap nodeMap = fromListUsingKey gnname (siNodes (fromSimpleItemWrapper si)) buggyNode k = GN { gup = [ AvPair "cat" (mkGConstNone $ "ERROR looking up" <+> k) ] , gdown = [] , gnname = "ERROR" , glexeme = [] , gtype = Other , ganchor = False , gaconstr = MaybeAdj , gorigin = "ERROR" } fromListUsingKey :: Ord k => (a -> k) -> [a] -> Map.Map k a fromListUsingKey f xs = Map.fromList [ (f x, x) | x <- xs ] instance XMGDerivation SimpleItem where -- Note: this is XMG-related stuff getSourceTrees it = map dsChild (siDerivation it) instance GraphvizShow (GvItem Bool SimpleItem) where graphvizLabel (GvHeader _) = "" graphvizLabel g@(GvItem _ _ c) = gvUnlines $ graphvizLabel (highlightSimpleItem g) : map TL.fromStrict (siDiagnostic (siGuiStuff c)) graphvizParams = graphvizParams . highlightSimpleItem graphvizShowAsSubgraph _ (GvHeader _) = [] graphvizShowAsSubgraph p g@(GvItem _ _ it) = graphvizShowAsSubgraph (p `TL.append` "TagElem") (highlightSimpleItem g) ++ graphvizShowDerivation (siDerivation it) highlightSimpleItem :: GvItem Bool SimpleItem -> GvItem GNodeHighlights SimpleItemWrapper highlightSimpleItem (GvHeader h) = GvHeader h highlightSimpleItem (GvItem l f it) = GvItem l (f, highlights) (SimpleItemWrapper it) where highlights :: Highlights (GNode GeniVal) highlights n = if gnname n `elem` siHighlight (siGuiStuff it) then Just (GV.X11Color GV.Red) else Nothing siToSentence :: SimpleItem -> T.Text siToSentence si = case unpackResult si of [] -> siIdname . siGuiStuff $ si (h:_) -> T.unwords ((idstr <> ".") : map lpLemma (snd3 h)) where idstr = pretty (siId si)