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 (..))
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)
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"
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
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
return (lay, onUpdate)
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
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)