-- 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)