-- 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 FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
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)

-- Main Gui

guiGeni :: ProgStateRef -> CustomSem sem -> IO()
guiGeni pstRef wrangler = start (mainGui pstRef wrangler)

mainGui :: ProgStateRef -> CustomSem sem -> IO ()
mainGui pstRef wrangler = do
    pst <- readIORef pstRef
    -- Top Window
    f <- frame [text := "Geni Project"]
    -- create statusbar field
    status <- statusField   []
    -- create the file menu
    fileMen   <- menuPane [text := "&File"]
    loadMenIt <- menuItem fileMen [text := "&Open files or configure GenI"]
    quitMenIt <- menuQuit fileMen [text := "&Quit"]
    set quitMenIt [on command := close f ]
    -- create the help menu
    helpMen   <- menuPane [text := "&Help"]
    aboutMeIt <- menuAbout helpMen [help := "About"]
    -- Tie the menu to this window
    set f [ statusBar := [status]
          , menuBar := [fileMen, helpMen]
          -- put the menu event handler for an about box on the frame.
          , on (menu aboutMeIt) := infoDialog f "About GenI"
             ("The GenI generator " ++ showVersion version ++
              ".\nhttp://kowey.github.com/GenI" )
          -- event handler for the tree browser
          -- , on (menu gbrowserMenIt) := do { loadEverything pstRef; treeBrowserGui pstRef }
          ]
    -- -----------------------------------------------------------------
    -- buttons
    -- -----------------------------------------------------------------
    let hasSem     = hasFlag TestSuiteFlg pst
    -- Target Semantics
    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 ]
    -- Detect polarities and root feature
    let initialDP = maybe "" showPolarityAttrs (getFlag DetectPolaritiesFlg pst)
        initialRF = maybe "" prettyStr (getFlag RootFeatureFlg pst)
    detectPolsTxt <- entry f [ text := initialDP ]
    rootFeatTxt   <- entry f [ text := initialRF ]
    -- Box and Frame for files loaded
    macrosFileLabel  <- staticText f [ text := getListFlag MacrosFlg pst ]
    lexiconFileLabel <- staticText f [ text := getListFlag LexiconFlg pst ]
    -- Generate and Debug
    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]
    -- -----------------------------------------------------------------
    -- optimisations
    -- -----------------------------------------------------------------
    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
    -- -----------------------------------------------------------------
    -- layout; packing it all together
    -- -----------------------------------------------------------------
    -- set any last minute handlers, run any last minute functions
    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 =  --boxed "Optimisations " $ -- can't used boxed with wxwidgets 2.6 -- bug?
                 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 $ -- boxed "Input Semantics" $
                          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 ]
                 -- ----------------------------- Generate and quit
                , row 1 [ widget quitBt
                       , hfloatRight $ row 5 [ widget pauseOnLexChk, widget debugBt, widget genBt ]] ]
         -- , clientSize := sz 625 325
         , 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 -- we want the latest config!
    -- errHandler title err = errorDialog f title (show err)
    set macrosFileLabel  [ text := getListFlag MacrosFlg  pst ]
    set lexiconFileLabel [ text := getListFlag LexiconFlg pst ]
    -- read the test suite if there is one
    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)

-- ----------------------------------------------------------------------
-- Toggling optimisations
-- ----------------------------------------------------------------------

-- | optimisation or pessimisation?
data OptType = Opti | Pessi

data OptBio = OptBio
    { odType     :: OptType
    , odOpt      :: Optimisation
    , odShortTxt :: String -- ^ confusing detail: always describes an optimisation
                           --   (so it says the straightforward thing for optimisations
                           --    but the opposite meaning for pessimisations)
    , odToolTip  :: String -- ^ see confusing detail above
    }

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 ]

-- | Note the following point about pessimisations: An pessimisation
--   disables a default behaviour which is assumed to be "optimisation".  But of
--   course we don't want to confuse the GUI user, so we confuse the programmer
--   instead: Given an pessimisation DisableFoo, we have a check box UseFoo.  If
--   UseFoo is checked, we remove DisableFoo from the list; if it is unchecked, we
--   add it to the list.  This is the opposite of the default behaviour, but the
--   result, I hope, is intuitive for the user.
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

-- --------------------------------------------------------------------
-- Loading files
-- --------------------------------------------------------------------

-- | Load the given test suite and update the GUI accordingly.
--   This is used when you first start the graphical interface
--   or when you run the configuration menu.
loadTestSuiteAndRefresh :: (Textual a, Selecting b, Selection b, Items b String)
              => Window w
              -> ProgStateRef
              -> CustomSem sem
              -> Instruction
              -> (a, b) -- ^ test suite text and case selector widgets
              -> 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

-- | Helper for 'loadTestSuiteAndRefresh'
onTestSuiteLoaded :: (Textual a, Selecting b, Selection b, Items b String)
                  => Window w
                  -> CustomSem sem  -- ^ handler for any semantics
                  -> [TestCase sem] -- ^ loaded suite
                  -> Maybe [Text]   -- ^ subset of test cases to select (instructions)
                  -> Maybe Text     -- ^ particular test case to focus on
                  -> (a, b) -- ^ test suite text and case selector widgets
                  -> IO ()
onTestSuiteLoaded f _ suite mcs mcase (tsBox, caseChoice) = do
    -- if the instructions specify a set of cases, we hide the cases that aren't mentioned
    let suiteCases = case filter (\c -> tcName c `elem` fromMaybe [] mcs) suite of
                       []  -> suite
                       res -> res
    -- handler for selecting a test case
    unless (null suiteCases) $ do
        initial <- getInitialSelection mcase suiteCases
        set caseChoice [ items := zipWith numfn [1..] suiteCases ]
        setSelection caseChoice suiteCases initial setTsBox
  where
    -- we number the cases for easy identification, putting
    -- a star to highlight the selected test case (if available)
    numfn :: Int -> TestCase sem -> String
    numfn n t = concat [ if hasName (fromMaybe "" mcase) t then "* " else ""
                       , show  n
                       , ". "
                       , T.unpack (tcName t)
                       ]
    -- first case selected is either specified
    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 ]

-- --------------------------------------------------------------------
-- Configuration
-- --------------------------------------------------------------------

-- | 'configGui' @pstRef loadFn@ provides the configuration GUI. The continuation
--   @loadFn@ tells us what to do when the user closes this window.
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)
    -- -----------------------------------------------------------------
    -- basic options tab
    -- -----------------------------------------------------------------
    pbas <- panel nb []
    -- files loaded (labels)
    macrosFileLabel  <- staticText pbas [ text := getListFlag MacrosFlg    pst ]
    lexiconFileLabel <- staticText pbas [ text := getListFlag LexiconFlg   pst ]
    tsFileLabel      <- staticText pbas [ text := getListFlag TestSuiteFlg pst ]
    -- "Browse buttons"
    macrosBrowseBt  <- button pbas [ text := browseTxt ]
    lexiconBrowseBt <- button pbas [ text := browseTxt ]
    tsBrowseBt      <- button pbas [ text := browseTxt ]
    -- root feature
    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 ]
                   ]
      -- the layout for the basic stuff
    let layBasic = dynamic $ container pbas $ -- boxed "Basic options" $
            hfloatLeft $ dynamic $ fill $ column 4 $ map (dynamic.hfill) layFiles
    -- -----------------------------------------------------------------
    -- advanced options tab
    -- -----------------------------------------------------------------
    padv <- panel nb []
    -- XMG tools
    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 ] ]
    -- morphology
    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 ] ]
    -- put the whole darn thing together
    let layAdvanced = hfloatLeft $ container padv
                    $ column 10 [ layXMG, layMorph ]
    -- -----------------------------------------------------------------
    -- browse button action
    --
    -- When the user clicks on a Browse button, an open file dialogue
    -- should pop up.  It gets its value from the file label on its left
    -- (passed in as an argument), and updates said label when the user has
    -- made a selection.
    -- -----------------------------------------------------------------
    -- helper functions
    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
              -- if the user does not select any file there are no changes
              Nothing   -> return ()
              Just file -> set theLabel [ text := makeRelative curDir file ]
    -- end onBrowse
    -- activate those "Browse" buttons
    let setBrowse w l = set w [ on command := onBrowse l ]
    setBrowse macrosBrowseBt macrosFileLabel
    setBrowse lexiconBrowseBt lexiconFileLabel
    setBrowse tsBrowseBt tsFileLabel
    setBrowse morphFileBrowseBt morphFileLabel
    -- -----------------------------------------------------------------
    -- config GUI layout
    -- -----------------------------------------------------------------
    let parseRF  = parseFlagWithParsec "root features" geniFeats . T.pack
        -- TODO: this is horrible! parseFlagWithParsec should be replaced with
        -- something safer
        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
    -- end onLoad
      -- the button bar
    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) ]
              ]
          ]

-- --------------------------------------------------------------------
-- Generation
-- --------------------------------------------------------------------

-- | 'doGenerate' parses the target semantics, then calls the generator and
--   displays the result in a results gui (below).
doGenerate :: Textual tb => Window a -> ProgStateRef
                         -> CustomSem sem
                         -> tb -- ^ sem
                         -> tb -- ^ polarities to detect
                         -> tb -- ^ root feature
                         -> 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)"
    -- sigh! Cocoa text boxes do autocorrection, which messes up this common
    -- bit of semantics; ideally I'd just figure out how to turn this off
    -- programmatically

resultsGui :: BG.BuilderGui -> ProgState -> CustomSem sem -> TestCase sem -> IO ()
resultsGui builderGui pst wrangler semInput = do
    -- results window
    f <- frame [ text := "Results"
               , fullRepaintOnResize := False
               , layout := stretch $ label "Generating..."
               , clientSize := sz 300 300
               ]
    p    <- panel f []
    nb   <- notebook p []
    -- input tab
    inputTab <- inputInfoGui nb (geniFlags (pa pst)) wrangler semInput
    -- realisations tab
    (results,_,summTab,resTab) <- BG.resultsPnl builderGui pst wrangler nb semInput
    -- ranking tab
    mRankTab <- if null (getRanking (pa pst))
                   then return Nothing
                   else Just <$> messageGui nb (purty results)
    -- tabs
    let myTabs = catMaybes
           [ Just (tab "summary"       summTab)
           , Just (tab "realisations"  resTab)
           , tab "ranking" <$> mRankTab
           , Just (tab "input"         inputTab)
           ]
    -- pack it all together
    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 ]


-- --------------------------------------------------------------------
-- Debugging
-- --------------------------------------------------------------------

-- | Information about the config/input in this session
inputInfoGui :: Window a -- ^ parent window
             -> [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)
  -- only show distinct a semantic block if we have a custom semantics
  -- otherwise, it's covered by the csemStr
  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 []

-- | We provide here a universal debugging interface, which makes use of some
--   parameterisable bits as defined in the BuilderGui module.
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) -- appends ts
                 , clientSize := bigSize
                 ]
           notebookSetSelection nb oldCount >> return ()
    --
    -- generation step 1
    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
        -- continuation for tree assembly tab
        let step3 results stats = do
                resPnl <- BG.summaryPnl builderGui pst nb results stats
                addTabs [tab "summary" resPnl]
        -- continuation for candidate selection tab
        let step2 newCands = do
               -- generation step 2.A (run polarity stuff)
               let newInitStuff = initStuff { B.inCands = map noBv newCands }
                   (input2, autstuff) = B.preInit newInitStuff (flags pst)
               -- automata tab
               mAutPnl <- if hasOpt Polarised (flags pst)
                             then Just <$> myPolarityGui nb autstuff
                             else return Nothing
               -- generation step 2.B (start the generator for each path)
               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 ]
        -- inputs tab
        inpPnl <- inputInfoGui nb (flags pst) wrangler tc
        -- lexical selection tab
        (canPnl,_,_) <- pauseOnLexGui (pa pst) nb
                           (B.inLex initStuff) cand initWarns $
                           if pauseOnLex then Just step2 else Nothing
        -- basic tabs
        addTabs [ tab "input"             inpPnl
                , tab "lexical selection" canPnl
                ]
        -- display all tabs if we are not told to pause on lex selection
        unless pauseOnLex (step2 cand)

-- ----------------------------------------------------------------------
-- odds and ends
-- ----------------------------------------------------------------------

bigSize :: Size2D Int
bigSize = sz 700 600

modifyParams :: (Params -> Params) -> ProgState -> ProgState
modifyParams f pst = pst { pa = f (pa pst) }

-- vim: set sw=4: