geni-gui 0.22.1 → 0.24
raw patch · 11 files changed
+640/−550 lines, 11 filesdep +transformersdep −strict-iodep −utf8-stringdep ~graphvizsetup-changed
Dependencies added: transformers
Dependencies removed: strict-io, utf8-string
Dependency ranges changed: graphviz
Files
- Setup.hs +14/−12
- geni-gui.cabal +6/−5
- geni-gui.hs +1/−1
- src/NLP/GenI/BuilderGui.hs +19/−15
- src/NLP/GenI/Graphviz.hs +72/−67
- src/NLP/GenI/GraphvizShow.hs +50/−44
- src/NLP/GenI/GraphvizShowPolarity.hs +74/−64
- src/NLP/GenI/Gui.hs +201/−175
- src/NLP/GenI/GuiHelper.hs +83/−73
- src/NLP/GenI/MainGui.hs +28/−24
- src/NLP/GenI/Simple/SimpleGui.hs +92/−70
Setup.hs view
@@ -1,18 +1,20 @@ {-# LANGUAGE CPP #-} -import Control.Monad (foldM_, forM_)-import Data.Maybe ( fromMaybe )-import System.Cmd-import System.Exit-import System.Info (os)-import System.FilePath-import System.Directory ( doesFileExist, copyFile, removeFile, createDirectoryIfMissing )+import Control.Monad (foldM_, forM_)+import Data.Maybe (fromMaybe)+import System.Cmd+import System.Directory (copyFile,+ createDirectoryIfMissing,+ doesFileExist, removeFile)+import System.Exit+import System.FilePath+import System.Info (os) -import Distribution.PackageDescription-import Distribution.MacOSX-import Distribution.Simple.Setup-import Distribution.Simple-import Distribution.Simple.LocalBuildInfo+import Distribution.MacOSX+import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup main :: IO () main = defaultMainWithHooks $ simpleUserHooks
geni-gui.cabal view
@@ -1,5 +1,5 @@ Name: geni-gui-Version: 0.22.1+Version: 0.24 License: GPL License-file: LICENSE Author: Carlos Areces and Eric Kow@@ -8,7 +8,7 @@ Homepage: http://projects.haskell.org/GenI Maintainer: geni-users@loria.fr Build-Type: Custom-Cabal-Version: >=1.8+Cabal-Version: >=1.14 Extra-source-files: macstuff/Info.plist, macstuff/wxmac.icns@@ -43,12 +43,12 @@ , mtl , process , split- , utf8-string- , strict-io+ , transformers , wx >= 0.12 , wxcore , text- , graphviz >= 2999.12 && < 2999.14+ , graphviz >= 2999.16 && < 2999.17+ Default-language: Haskell2010 Executable geni-gui Main-Is: geni-gui.hs@@ -59,3 +59,4 @@ Build-Depends: base >= 4 && < 5 , GenI , geni-gui+ Default-language: Haskell2010
geni-gui.hs view
@@ -17,4 +17,4 @@ module Main (module NLP.GenI.MainGui) where -import NLP.GenI.MainGui+import NLP.GenI.MainGui
src/NLP/GenI/BuilderGui.hs view
@@ -18,12 +18,14 @@ {-# LANGUAGE RankNTypes #-} module NLP.GenI.BuilderGui where -import Graphics.UI.WX+import Graphics.UI.WX -import qualified NLP.GenI.Builder as B-import NLP.GenI (ProgStateRef, GeniResult)-import NLP.GenI.Semantics-import NLP.GenI.Statistics (Statistics)+import NLP.GenI (GeniResult, ProgState)+import qualified NLP.GenI.Builder as B+import NLP.GenI.Control+import NLP.GenI.LexicalSelection (CustomSem)+import NLP.GenI.Statistics (Statistics)+import NLP.GenI.TestSuite -- | Once upon a time, GenI had two very different algorithms for tree assembly, -- a CKY/Early style one using packed trees; and the traditional “simple“@@ -36,24 +38,26 @@ { -- | A 'resultsPnl' returns results, statistics and layouts for -- a panel showing detailed results (eg. with trees and what not) -- and one showing a summary of the results- resultsPnl :: forall a- . ProgStateRef - -> Window a -- ^ parent- -> SemInput+ resultsPnl :: forall a sem+ . ProgState+ -> CustomSem sem+ -> Window a -- parent+ -> TestCase sem -> IO ([GeniResult],Statistics,Layout,Layout) -- | Just a sentence summary tab (small part of the resultsPnl) , summaryPnl :: forall a- . ProgStateRef- -> Window a -- ^ parent+ . ProgState+ -> Window a -- parent -> [GeniResult] -> Statistics -> IO Layout , debuggerPnl :: forall a- . ProgStateRef- -> Window a -- ^ parent+ . ProgState+ -> Maybe Params -- test case parameters+ -> Window a -- parent -> B.Input- -> String -- ^ name of the builder algorithm+ -> String -- name of the builder algorithm -> ([GeniResult] -> Statistics -> IO ())- -- ^ what to do when we get results+ -- what to do when we get results -> IO Layout }
src/NLP/GenI/Graphviz.hs view
@@ -1,20 +1,23 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} {- 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.@@ -22,7 +25,7 @@ {- | Graphviz is an open source tool which converts an abstract representation of a graph (node foo is connected to node bar, etc.)- into a nicely laid out graphic. This module contains methods + into a nicely laid out graphic. This module contains methods to invoke graphviz and to convert graphs and trees to its input format. You can download this (open source) tool at@@ -32,16 +35,16 @@ module NLP.GenI.Graphviz where -import Control.Arrow ( second )-import Data.GraphViz-import Data.GraphViz.Printing ( printIt )-import Data.GraphViz.Attributes.Complete+import Control.Arrow (second)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T+import Data.Tree+import Prelude hiding (writeFile) -import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.IO as T-import Data.Text.Lazy ( Text )-import Data.Tree-import Prelude hiding ( writeFile )+import Data.GraphViz+import Data.GraphViz.Attributes.Complete+import Data.GraphViz.Printing (printIt) {- | Data structures which can be visualised with GraphViz should@@ -52,49 +55,50 @@ can hide this by turning off edge arrows. -} class GraphvizShow b where- graphvizShowGraph :: b -> DotGraph Text- graphvizShowAsSubgraph :: Text -- ^ prefix- -> b -- ^ item- -> [DotSubGraph Text] -- ^ gv output- graphvizLabel :: b -- ^ item- -> Text -- ^ gv output- graphvizParams :: b -> [GlobalAttributes]+ graphvizShowGraph :: b -> DotGraph Text+ graphvizShowAsSubgraph :: Text -- ^ prefix+ -> b -- ^ item+ -> [DotSubGraph Text] -- ^ gv output+ graphvizLabel :: b -- ^ item+ -> Text -- ^ gv output+ graphvizParams :: b -> [GlobalAttributes] - graphvizShowGraph b =- DotGraph False True Nothing $ DotStmts- (addLabel (graphvizLabel b) $ graphvizParams b)- (graphvizShowAsSubgraph "_" b)- []- []- where- addLabel :: Text -> [GlobalAttributes] -> [GlobalAttributes]- addLabel "" = id- addLabel l = (GraphAttrs [Label (StrLabel l)] :)+ graphvizShowGraph b =+ DotGraph False True Nothing $ DotStmts+ (addLabel (graphvizLabel b) $ graphvizParams b)+ (graphvizShowAsSubgraph "_" b)+ []+ []+ where+ addLabel :: Text -> [GlobalAttributes] -> [GlobalAttributes]+ addLabel "" = id+ addLabel l = (GraphAttrs [Label (StrLabel l)] :) - graphvizLabel _ = ""- graphvizParams _ = []+ graphvizLabel _ = ""+ graphvizParams _ = [] class GraphvizShowNode b where- graphvizShowNode :: Text -- ^ prefix- -> b -- ^ item - -> DotNode Text -- ^ gv output+ graphvizShowNode :: Text -- ^ prefix+ -> b -- ^ item+ -> DotNode Text -- ^ gv output -- | Things which are meant to be displayed within some other graph -- as (part) of a node label class GraphvizShowString b where- graphvizShow :: b -- ^ item- -> Text -- ^ gv output+ graphvizShow :: b -- ^ item+ -> Text -- ^ gv output -- | Note: the 'dotFile' argument allows you to save the intermediary -- dot output to a file. You can pass in the empty string if you don't-toGraphviz :: GraphvizShow a => a- -> String -- ^ the 'dotFile'- -> String -> IO FilePath+toGraphviz :: GraphvizShow a+ => a+ -> String -- ^ the 'dotFile'+ -> String -> IO FilePath toGraphviz x dotFile outputFile = do- T.writeFile dotFile (printIt g)- runGraphviz g Png outputFile- where- g = graphvizShowGraph x+ T.writeFile dotFile (printIt g)+ runGraphviz g Png outputFile+ where+ g = graphvizShowGraph x -- --------------------------------------------------------------------- -- useful utility functions@@ -104,23 +108,23 @@ gvUnlines = T.intercalate "\n" -- ------------------------------------------------------------------------ some instances +-- some instances -- --------------------------------------------------------------------- instance GraphvizShow b => GraphvizShow (Maybe b) where- graphvizShowAsSubgraph _ Nothing = []- graphvizShowAsSubgraph p (Just b) = graphvizShowAsSubgraph p b+ graphvizShowAsSubgraph _ Nothing = []+ graphvizShowAsSubgraph p (Just b) = graphvizShowAsSubgraph p b - graphvizLabel Nothing = ""- graphvizLabel (Just b) = graphvizLabel b+ graphvizLabel Nothing = ""+ graphvizLabel (Just b) = graphvizLabel b - graphvizParams Nothing = []- graphvizParams (Just b) = graphvizParams b+ graphvizParams Nothing = []+ graphvizParams (Just b) = graphvizParams b --- | Displays a tree in graphviz format. +-- | Displays a tree in graphviz format. {- Note that we could make this an instance of GraphvizShow, but I'm not too sure about the wisdom of- such a move. + such a move. Maybe if we had some really super-sophisticated types in Haskell, where we can define this as the default instance which could be overrided by@@ -131,19 +135,20 @@ the 2nd child of the root) to keep them distinct. Note : We use the letter `x' as seperator because graphviz will choke on `.' or `-', even underscore. -}-gvShowTree :: GraphvizShowNode n =>- Text -- ^ node prefix- -> Tree n -- ^ the tree- -> DotSubGraph Text+gvShowTree :: GraphvizShowNode n+ => Text -- ^ node prefix+ -> Tree n -- ^ the tree+ -> DotSubGraph Text gvShowTree prefix t =- DotSG False Nothing $ DotStmts atts [] nodes edges- where- atts = [ EdgeAttrs [ ArrowHead noArrow ] ] -- should be none- (nodes, edges) = second concat . unzip $ walk prefix t- --- walk pref (Node node xs) =- let mkPrefix i = T.concat [pref, "x", T.pack (show i)]+ DotSG False Nothing $ DotStmts atts [] nodes edges+ where+ atts = [ EdgeAttrs [ ArrowHead noArrow ] ] -- should be none+ (nodes, edges) = second concat . unzip $ walk prefix t+ --+ walk pref (Node node xs) =+ (ns, es) : concat (zipWith walk ps xs)+ where+ mkPrefix i = T.concat [pref, "x", T.pack (show i)] ns = graphvizShowNode pref node ps = map mkPrefix [1::Int .. length xs] es = map (\n -> DotEdge pref n []) ps- in (ns, es) : concat (zipWith walk ps xs)
src/NLP/GenI/GraphvizShow.hs view
@@ -15,39 +15,37 @@ -- 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, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-} -- | Outputting core GenI data to graphviz. module NLP.GenI.GraphvizShow where -import Control.Applicative ( (<$>) )-import Data.FullList ( fromFL )-import Data.List ( nub )-import Data.Maybe(listToMaybe, maybeToList, mapMaybe)-import qualified Data.Text.Lazy as TL-import qualified Data.Text as T+import Control.Applicative ((<$>))+import Data.FullList (fromFL)+import Data.Int (Int64)+import Data.List (nub)+import Data.Maybe+import Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL -import Data.GraphViz-import Data.GraphViz.Attributes.Complete+import Data.GraphViz+import Data.GraphViz.Attributes.Complete -import NLP.GenI.FeatureStructure ( AvPair(..), Flist )-import NLP.GenI.General ( clumpBy )-import NLP.GenI.Pretty-import NLP.GenI.GeniVal (GeniVal(..), isConst)-import NLP.GenI.Graphviz- ( GraphvizShow(graphvizShowAsSubgraph, graphvizLabel, graphvizParams)- , GraphvizShowNode(graphvizShowNode)- , GraphvizShowString(graphvizShow)- , gvUnlines, gvShowTree- )-import NLP.GenI.Semantics ( Sem )-import NLP.GenI.Tag- ( TagDerivation, TagItem(..), TagElem(..)- , DerivationStep(..), dsChild, dsParent- )-import NLP.GenI.TreeSchema ( GNode(..), GType(..) )+import NLP.GenI.FeatureStructure (AvPair (..), Flist)+import NLP.GenI.GeniVal (GeniVal (..))+import NLP.GenI.Graphviz+import NLP.GenI.Pretty hiding ((<>))+import NLP.GenI.Semantics (Sem)+import NLP.GenI.Tag+import NLP.GenI.TreeSchema (AdjunctionConstraint(..),+ GNode (..), GType (..)) -- ---------------------------------------------------------------------- --@@ -126,11 +124,7 @@ ] gvShowSem :: Sem -> TL.Text-gvShowSem = gvUnlines- . map (TL.pack . unwords)- . clumpBy length 72- . words- . prettyStr+gvShowSem = TL.fromStrict. squeezed 70 . map pretty -- ---------------------------------------------------------------------- -- Helper functions for the TagElem GraphvizShow instance@@ -149,7 +143,7 @@ where -- attributes filledParam = Style [SItem Filled []]- fillcolorParam = FillColor (X11Color LemonChiffon)+ fillcolorParam = FillColor [toWC (X11Color LemonChiffon)] shapeRecordParam = Shape Record shapePlaintextParam = Shape PlainText --@@ -199,10 +193,12 @@ showGnDecorations :: GNode GeniVal -> TL.Text showGnDecorations gn =- case gtype gn of- Subs -> "↓"- Foot -> "*"- _ -> if gaconstr gn then "ᴺᴬ" else ""+ case (gtype gn, gaconstr gn) of+ (Subs, _) -> "↓"+ (Foot, _) -> "*"+ (_, ExplicitNoAdj) -> "ᴺᴬ"+ (_, InferredNoAdj) -> "ᴵᴺᴬ"+ (_, MaybeAdj) -> "" showGnStub :: GNode GeniVal -> TL.Text showGnStub gn =@@ -213,7 +209,9 @@ Just v -> graphvizShow_ v getIdx f = case getGnVal f "idx" gn of Nothing -> ""- Just v -> if isConst v then graphvizShow_ v else ""+ Just v -> if isJust (gConstraints v)+ then graphvizShowShort 8 v+ else "" idxT = getIdx gup idxB = getIdx gdown idx = tackOn "." idxT idxB@@ -235,6 +233,13 @@ graphvizShow_ :: GraphvizShowString a => a -> TL.Text graphvizShow_ = graphvizShow +-- | If too wide, truncate and display ellipsis+graphvizShowShort :: GraphvizShowString a => Int64 -> a -> TL.Text+graphvizShowShort mx x =+ if TL.length t > mx then TL.take mx t <> "…" else t+ where+ t = graphvizShow x+ -- ---------------------------------------------------------------------- -- Derivation tree -- ----------------------------------------------------------------------@@ -244,9 +249,9 @@ derivationToGv :: TagDerivation -> Maybe (DotSubGraph TL.Text) derivationToGv deriv =- if null histNodes- then Nothing- else Just $ DotSG False Nothing $ DotStmts atts [] nodes edges+ if null histNodes+ then Nothing+ else Just $ DotSG False Nothing $ DotStmts atts [] nodes edges where atts = [ NodeAttrs [ Shape PlainText ] , EdgeAttrs [ ArrowHead noArrow ]@@ -258,10 +263,11 @@ mkNode n = DotNode (gvDerivationLab n) [ Label . StrLabel $ label n ] mkEdge ds = do- p <- dsParent ds- return $ DotEdge (gvDerivationLab p)- (gvDerivationLab (dsChild ds))- (edgeStyle ds)+ p <- dsParent ds+ return $ DotEdge+ (gvDerivationLab p)+ (gvDerivationLab (dsChild ds))+ (edgeStyle ds) edgeStyle (AdjunctionStep {}) = [Style [SItem Dashed []]] edgeStyle _ = [] label n =
src/NLP/GenI/GraphvizShowPolarity.hs view
@@ -15,87 +15,97 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module NLP.GenI.GraphvizShowPolarity where -import Data.List (intercalate)-import qualified Data.Map as Map-import Data.Maybe ( catMaybes )-import Data.GraphViz-import Data.GraphViz.Attributes.Complete+import Data.List (intercalate)+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy as TL-import NLP.GenI.General(showInterval)-import NLP.GenI.Polarity(PolAut, PolState(PolSt), NFA(states, transitions), finalSt)-import NLP.GenI.Pretty-import NLP.GenI.Graphviz(GraphvizShow(..), gvUnlines)-import NLP.GenI.Tag (idname)+import Data.GraphViz+import Data.GraphViz.Attributes.Complete +import NLP.GenI.General (showInterval)+import NLP.GenI.Graphviz (GraphvizShow (..),+ gvUnlines)+import NLP.GenI.Polarity (NFA (states, transitions),+ PolAut, PolState (PolSt),+ finalSt)+import NLP.GenI.Pretty+import NLP.GenI.Tag (idname)+ instance GraphvizShow PolAut where- -- we want a directed graph (arrows)- graphvizShowGraph aut =- DotGraph False True Nothing $ DotStmts- [ GraphAttrs [RankDir FromLeft, RankSep [0.02], Pack (PackMargin 1)]- , NodeAttrs [FontSize 10]- , EdgeAttrs [FontSize 10]- ]- (graphvizShowAsSubgraph "aut" aut)- [] -- all nodes are in the subgraph- []+ -- we want a directed graph (arrows)+ graphvizShowGraph aut =+ DotGraph False True Nothing $ DotStmts+ atts+ (graphvizShowAsSubgraph "aut" aut)+ [] -- all nodes are in the subgraph+ []+ where+ atts =+ [ GraphAttrs [RankDir FromLeft, RankSep [0.02], Pack (PackMargin 1)]+ , NodeAttrs [FontSize 10]+ , EdgeAttrs [FontSize 10]+ ] - --- graphvizShowAsSubgraph prefix aut =- [ DotSG False Nothing+ graphvizShowAsSubgraph prefix aut =+ [ DotSG False Nothing $ DotStmts [ NodeAttrs [ Shape Ellipse, Peripheries 1 ] ] [] (zipWith (gvShowState fin) ids st) (concat $ zipWith (gvShowTrans aut stmap) ids st)- ]- where- st = (concat.states) aut- fin = finalSt aut- ids = map (\x -> prefix `TL.append` TL.pack (show x)) ([0..] :: [Int])- -- map which permits us to assign an id to a state- stmap = Map.fromList $ zip st ids+ ]+ where+ st = (concat.states) aut+ fin = finalSt aut+ ids = map (\x -> prefix <> TL.pack (show x)) ([0..] :: [Int])+ -- map which permits us to assign an id to a state+ stmap = Map.fromList $ zip st ids gvShowState :: [PolState] -> TL.Text -> PolState -> DotNode TL.Text gvShowState fin stId st =- DotNode stId $ decorate [ Label . StrLabel . showSt $ st ]+ DotNode stId $ decorate [ Label . StrLabel . showSt $ st ] where- showSt (PolSt _ ex po) =- gvUnlines . catMaybes $- [ Nothing -- Just (snd3 pr)- , if null ex then Nothing else Just (TL.fromChunks [pretty ex])- , Just . TL.pack . intercalate "," $ map showInterval po- ]- decorate = if st `elem` fin- then (Peripheries 2 :)- else id+ showSt (PolSt _ ex po) = gvUnlines . catMaybes $+ [ Nothing -- Just (snd3 pr)+ , if null ex then Nothing else Just (TL.fromChunks [pretty ex])+ , Just . TL.pack . intercalate "," $ map showInterval po+ ]+ decorate =+ if st `elem` fin then (Peripheries 2 :) else id gvShowTrans :: PolAut -> Map.Map PolState TL.Text -> TL.Text -> PolState -> [DotEdge TL.Text] gvShowTrans aut stmap idFrom st =- let -- outgoing transition labels from st- trans = Map.findWithDefault Map.empty st $ transitions aut- -- returns the graphviz dot command to draw a labeled transition- drawTrans (stTo,x) = case Map.lookup stTo stmap of- Nothing -> drawTrans' ("id_error_" `TL.append` (TL.pack (sem_ stTo))) x- Just idTo -> drawTrans' idTo x- where sem_ (PolSt i _ _) = show i- --showSem (PolSt (_,pred,_) _ _) = pred- drawTrans' idTo x = DotEdge idFrom idTo [Label (drawLabel x)]- drawLabel labels = StrLabel . gvUnlines $ labs- where- lablen = length labels- maxlabs = 6- excess = TL.pack $ "...and " ++ show (lablen - maxlabs) ++ " more"- --- name t = TL.fromChunks [ idname t ]- labstrs = map (maybe "EMPTY" name) labels- labs = if lablen > maxlabs- then take maxlabs labstrs ++ [ excess ]- else labstrs- in map drawTrans (Map.toList trans)+ map drawTrans (Map.toList trans)+ where+ -- outgoing transition labels from st+ trans = Map.findWithDefault Map.empty st $ transitions aut+ -- returns the graphviz dot command to draw a labeled transition+ drawTrans (stTo,x) =+ case Map.lookup stTo stmap of+ Nothing -> drawTrans' ("id_error_" `TL.append` (TL.pack (sem_ stTo))) x+ Just idTo -> drawTrans' idTo x+ where+ sem_ (PolSt i _ _) = show i+ --showSem (PolSt (_,pred,_) _ _) = pred+ drawTrans' idTo x = DotEdge idFrom idTo [Label (drawLabel x)]+ drawLabel labels =+ StrLabel . gvUnlines $ labs+ where+ lablen = length labels+ maxlabs = 6+ excess = TL.pack $ "...and " ++ show (lablen - maxlabs) ++ " more"+ --+ name t = TL.fromChunks [ idname t ]+ labstrs = map (maybe "EMPTY" name) labels+ labs = if lablen > maxlabs+ then take maxlabs labstrs ++ [ excess ]+ else labstrs
src/NLP/GenI/Gui.hs view
@@ -15,65 +15,58 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} module NLP.GenI.Gui (guiGeni) where -import Control.Applicative ( (<$>) )-import Control.Exception ( catch, try, SomeException )-import Control.Monad ( unless )-import Data.IORef ( readIORef, modifyIORef )-import Data.List ( nub, delete, findIndex)-import Data.Maybe ( fromMaybe, catMaybes )-import Data.Text ( Text )-import Data.Version ( showVersion )-import Prelude hiding ( catch )-import System.Directory-import System.Exit (exitWith, ExitCode(ExitSuccess))-import System.FilePath ( makeRelative )-import qualified Data.Text as T+import Control.Applicative ((<$>))+import Control.Exception (SomeException, catch, try)+import Control.Monad (unless)+import Control.Monad.Trans.Error+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 hiding (catch)+import System.Directory+import System.Exit (ExitCode (ExitSuccess), exitWith)+import System.FilePath (makeRelative) -import Graphics.UI.WX-import Graphics.UI.WXCore+import Graphics.UI.WX+import Graphics.UI.WXCore -import NLP.GenI- ( ProgState(..), ProgStateRef, initGeni , GeniResult(..), prettyResult- , parseSemInput, loadEverything, loadTestSuite- )-import NLP.GenI.Configuration- ( Params(..), Instruction, hasOpt , hasFlagP- , deleteFlagP, setFlagP, getFlagP, getListFlagP- , parseFlagWithParsec- --- , DetectPolaritiesFlg(..) , LexiconFlg(..)- , MacrosFlg(..) , MorphCmdFlg(..) , MorphInfoFlg(..), OptimisationsFlg(..)- , RankingConstraintsFlg(..) , RootFeatureFlg(..) , TestCaseFlg(..)- , TestSuiteFlg(..) , TestInstructionsFlg(..) , ViewCmdFlg(..)- --- , Optimisation(..) , BuilderType(..), mainBuilderTypes- )-import NLP.GenI.General (fst3, prettyException, trim)-import NLP.GenI.GeniShow ( geniShow, geniShowText )-import NLP.GenI.GuiHelper-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 )-import qualified NLP.GenI.Builder as B-import qualified NLP.GenI.BuilderGui as BG+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 -> IO()-guiGeni pstRef = start (mainGui pstRef)+guiGeni :: ProgStateRef -> CustomSem sem -> IO()+guiGeni pstRef wrangler = start (mainGui pstRef wrangler) -mainGui :: ProgStateRef -> IO ()-mainGui pstRef = do+mainGui :: ProgStateRef -> CustomSem sem -> IO ()+mainGui pstRef wrangler = do pst <- readIORef pstRef -- Top Window f <- frame [text := "Geni Project"]@@ -93,33 +86,32 @@ -- 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://projects.haskell.org/GenI" )+ ".\nhttp://kowey.github.com/GenI" ) -- event handler for the tree browser -- , on (menu gbrowserMenIt) := do { loadEverything pstRef; treeBrowserGui pstRef } ] -- ----------------------------------------------------------------- -- buttons -- ------------------------------------------------------------------ let config = pa pst- hasSem = hasFlagP TestSuiteFlg config+ let hasSem = hasFlag TestSuiteFlg pst -- Target Semantics testSuiteChoice <- choice f [ selection := 0, enabled := hasSem ] tsTextBox <- textCtrl f [ wrap := WrapWord- , clientSize := sz 400 80+ , clientSize := sz 200 80 , enabled := hasSem , text := "" ] testCaseChoice <- choice f [ selection := 0 , enabled := hasSem ] -- Detect polarities and root feature- let initialDP = maybe "" showPolarityAttrs (getFlagP DetectPolaritiesFlg config)- initialRF = maybe "" prettyStr (getFlagP RootFeatureFlg config)+ 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 := getListFlagP MacrosFlg config ]- lexiconFileLabel <- staticText f [ text := getListFlagP LexiconFlg config ]+ macrosFileLabel <- staticText f [ text := getListFlag MacrosFlg pst ]+ lexiconFileLabel <- staticText f [ text := getListFlag LexiconFlg pst ] -- Generate and Debug- let genfn = doGenerate f pstRef tsTextBox detectPolsTxt rootFeatTxt+ 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 ]@@ -130,13 +122,14 @@ -- optimisations -- ----------------------------------------------------------------- let setBuilder b = modifyIORef pstRef . modifyParams- $ \p -> p { builderType = b }- initialSelection = case builderType config of+ $ \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@@ -150,7 +143,7 @@ , testCaseChoice = testCaseChoice , tsTextBox = tsTextBox }- onLoad = mainOnLoad pstRef myWidgets+ onLoad = mainOnLoad pstRef wrangler myWidgets set loadMenIt [ on command := configGui pstRef onLoad ] onLoad --@@ -165,6 +158,7 @@ , dynamic $ widget algoChoiceBox , label "Optimisations" , dynamic $ widget polChk+ , dynamic $ widget guidedRealisationChk , dynamic $ widget useSemConstraintsChk ] set f [layout := column 5 [ gramsemBox@@ -197,21 +191,21 @@ , tsTextBox :: TextCtrl () } -mainOnLoad :: ProgStateRef -> MainWidgets -> IO ()-mainOnLoad pstRef (MainWidgets {..}) = do- cfg <- pa `fmap` readIORef pstRef -- we want the latest config!+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 := getListFlagP MacrosFlg cfg ]- set lexiconFileLabel [ text := getListFlagP LexiconFlg cfg ]+ set macrosFileLabel [ text := getListFlag MacrosFlg pst ]+ set lexiconFileLabel [ text := getListFlag LexiconFlg pst ] -- read the test suite if there is one- case getListFlagP TestInstructionsFlg cfg 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 t (tsTextBox, testCaseChoice)+ 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@@ -239,8 +233,13 @@ "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, semConstraintBio ]+optBios = [ polarisedBio, guidedRealisationBio, semConstraintBio ] -- | Note the following point about pessimisations: An pessimisation -- disables a default behaviour which is assumed to be "optimisation". But of@@ -251,8 +250,8 @@ -- result, I hope, is intuitive for the user. optCheckBox :: Window a -> ProgStateRef -> OptBio -> IO (CheckBox ()) optCheckBox f pstRef od = do- config <- pa <$> readIORef pstRef- chk <- checkBox f [ checked := flippy (hasOpt o config)+ pst <- readIORef pstRef+ chk <- checkBox f [ checked := flippy (hasOpt o (flags pst)) , text := odShortTxt od , tooltip := odToolTip od ]@@ -261,14 +260,14 @@ where o = odOpt od flippy = case odType od of- Opti -> id- Pessi -> not+ Opti -> id+ Pessi -> not onCheck chk = do isChecked <- get chk checked- config <- pa <$> readIORef pstRef+ pst <- readIORef pstRef let modopt = if flippy isChecked then (o:) else delete o- newopts = nub . modopt $ getListFlagP OptimisationsFlg config- modifyIORef pstRef . modifyParams $ setFlagP OptimisationsFlg newopts+ newopts = nub . modopt $ getListFlag OptimisationsFlg pst+ modifyIORef pstRef . modifyParams $ setFlag OptimisationsFlg newopts -- -------------------------------------------------------------------- -- Loading files@@ -280,26 +279,29 @@ 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 (suitePath,mcs) widgets = do- pst <- readIORef pstRef- msuite <- try (loadTestSuite pstRef)- let mcase = getFlagP TestCaseFlg (pa pst)+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 s mcs mcase widgets+ Right s -> onTestSuiteLoaded f wrangler s mcs mcase widgets -- | Helper for 'loadTestSuiteAndRefresh' onTestSuiteLoaded :: (Textual a, Selecting b, Selection b, Items b String) => Window w- -> [TestCase] -- ^ loaded suite+ -> 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+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@@ -312,7 +314,7 @@ where -- we number the cases for easy identification, putting -- a star to highlight the selected test case (if available)- numfn :: Int -> TestCase -> String+ numfn :: Int -> TestCase sem -> String numfn n t = concat [ if hasName (fromMaybe "" mcase) t then "* " else "" , show n , ". "@@ -329,7 +331,7 @@ hasName name tc = tcName tc == name -- setTsBox (TestCase {..}) =- set tsBox [ text := geniShow (toSemInputString tcSem tcSemString) ]+ set tsBox [ text := T.unpack tcSemString ] -- -------------------------------------------------------------------- -- Configuration@@ -340,7 +342,6 @@ configGui :: ProgStateRef -> IO () -> IO () configGui pstRef loadFn = do pst <- readIORef pstRef- let config = pa pst -- f <- frame [] p <- panel f []@@ -356,9 +357,9 @@ -- ----------------------------------------------------------------- pbas <- panel nb [] -- files loaded (labels)- macrosFileLabel <- staticText pbas [ text := getListFlagP MacrosFlg config ]- lexiconFileLabel <- staticText pbas [ text := getListFlagP LexiconFlg config ]- tsFileLabel <- staticText pbas [ text := getListFlagP TestSuiteFlg config ]+ 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 ]@@ -366,10 +367,10 @@ -- root feature detectPolsTxt <- entry pbas [ text := maybe "" showPolarityAttrs- (getFlagP DetectPolaritiesFlg config)+ (getFlag DetectPolaritiesFlg pst) , size := longSize ] rootFeatTxt <- entry pbas- [ text := maybe "" prettyStr (getFlagP RootFeatureFlg config)+ [ text := maybe "" prettyStr (getFlag RootFeatureFlg pst) , size := longSize ] let layFiles = [ row 1 [ label "trees:" , fill $ widget macrosFileLabel@@ -399,16 +400,16 @@ -- XMG tools viewCmdTxt <- entry padv [ tooltip := "Command used for XMG tree viewing"- , text := getListFlagP ViewCmdFlg config ]+ , text := getListFlag ViewCmdFlg pst ] let layXMG = fakeBoxed "XMG tools" [ row 3 [ label "XMG view command" , marginRight $ hfill $ widget viewCmdTxt ] ] -- morphology- morphFileLabel <- staticText padv [ text := getListFlagP MorphInfoFlg config ]+ morphFileLabel <- staticText padv [ text := getListFlag MorphInfoFlg pst ] morphFileBrowseBt <- button padv [ text := browseTxt ] morphCmdTxt <- entry padv [ tooltip := "Commmand used for morphological generation"- , text := getListFlagP MorphCmdFlg config ]+ , text := getListFlag MorphCmdFlg pst ] let layMorph = fakeBoxed "Morphology" [ row 3 [ label "morph info:" , expand $ hfill $ widget morphFileLabel@@ -448,7 +449,7 @@ -- ----------------------------------------------------------------- -- config GUI layout -- ------------------------------------------------------------------ let parseRF = parseFlagWithParsec "root features" geniFeats+ let parseRF = parseFlagWithParsec "root features" geniFeats . T.pack -- TODO: this is horrible! parseFlagWithParsec should be replaced with -- something safer onLoad@@ -465,14 +466,14 @@ morphInfoVal <- get morphFileLabel text -- let maybeSet fl fn x =- if null x then deleteFlagP fl else setFlagP 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)]- . setFlagP DetectPolaritiesFlg (readPolarityAttrs detectPolsVal)+ . setFlag DetectPolaritiesFlg (readPolarityAttrs detectPolsVal) . maybeSet RootFeatureFlg parseRF rootCatVal . maybeSetStr ViewCmdFlg viewVal . maybeSetStr MorphCmdFlg morphCmdVal@@ -499,43 +500,46 @@ -- | '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 sembox detectPolsTxt rootFeatTxt useDebugger pauseOnLex = do- let parseRF = parseFlagWithParsec "root features" geniFeats+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 deleteFlagP fl else setFlagP fl (fn x)+ if null x then deleteFlag fl else setFlag fl (fn x) let setConfig = id . maybeSet RootFeatureFlg parseRF rootCatVal- . setFlagP DetectPolaritiesFlg (readPolarityAttrs detectPolsVal)+ . setFlag DetectPolaritiesFlg (readPolarityAttrs detectPolsVal) modifyIORef pstRef (modifyParams setConfig)+ -- minput <- do set sembox [ text :~ trim ]- loadEverything pstRef- parseSemInput <$> get sembox text+ loadEverything pstRef wrangler+ customSemParser wrangler . T.pack <$> get sembox text case minput of Left e -> errorDialog f "Please give me better input" (show e) Right semInput -> do- let doDebugger bg = debugGui bg pstRef semInput pauseOnLex- doResults bg = resultsGui bg pstRef semInput+ 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- config <- pa <$> readIORef pstRef- case builderType config of- SimpleBuilder -> a simpleGui2p- SimpleOnePhaseBuilder -> a simpleGui1p+ pst <- readIORef pstRef+ case getBuilderType (pa pst) of+ SimpleBuilder -> a simpleGui2p+ SimpleOnePhaseBuilder -> a simpleGui1p -resultsGui :: BG.BuilderGui -> ProgStateRef -> SemInput -> IO ()-resultsGui builderGui pstRef semInput = do+resultsGui :: BG.BuilderGui -> ProgState -> CustomSem sem -> TestCase sem -> IO ()+resultsGui builderGui pst wrangler semInput = do -- results window f <- frame [ text := "Results" , fullRepaintOnResize := False@@ -544,15 +548,14 @@ ] p <- panel f [] nb <- notebook p []- pst <- readIORef pstRef -- input tab- inputTab <- inputInfoGui nb (pa pst) semInput+ inputTab <- inputInfoGui nb (geniFlags (pa pst)) wrangler semInput -- realisations tab- (results,_,summTab,resTab) <- BG.resultsPnl builderGui pstRef nb semInput+ (results,_,summTab,resTab) <- BG.resultsPnl builderGui pst wrangler nb semInput -- ranking tab- mRankTab <- if hasFlagP RankingConstraintsFlg (pa pst)- then Just <$> messageGui nb (purty pst results)- else return Nothing+ mRankTab <- if null (getRanking (pa pst))+ then return Nothing+ else Just <$> messageGui nb (purty results) -- tabs let myTabs = catMaybes [ Just (tab "summary" summTab)@@ -566,7 +569,7 @@ repaint f return () where- purty pst res = T.unlines $ map (prettyResult pst) [ x | GSuccess x <- res ]+ purty res = T.unlines $ map (prettyResult pst) [ x | GSuccess x <- res ] -- --------------------------------------------------------------------@@ -575,28 +578,45 @@ -- | Information about the config/input in this session inputInfoGui :: Window a -- ^ parent window- -> Params- -> SemInput+ -> [Flag]+ -> CustomSem sem+ -> TestCase sem -> IO Layout-inputInfoGui f config semInput = messageGui f . T.unlines $- [ geniShowText semInput- , ""- , "Options"+inputInfoGui f flags_ wrangler tc = messageGui f . T.unlines $+ [ csemStr, "" ] ++ semBlock +++ [ "Options" , "-------"- , "Root feature: " <> maybe "" pretty (getFlagP RootFeatureFlg config)+ , "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) config- dps = maybe "" showPolarityAttrs (getFlagP DetectPolaritiesFlg config)+ configged od = hasOpt (odOpt od) flags_+ dps = maybe "" showPolarityAttrs (getFlag DetectPolaritiesFlg flags_) polStuff = if enabld polarisedBio then [ "" , "Detect polarities: " <> T.pack dps@@ -605,12 +625,9 @@ -- | We provide here a universal debugging interface, which makes use of some -- parameterisable bits as defined in the BuilderGui module.-debugGui :: BG.BuilderGui -> ProgStateRef -> SemInput -> Bool -> IO ()-debugGui builderGui pstRef semInput pauseOnLex = do- config <- pa <$> readIORef pstRef- let btype = show (builderType config)- --- f <- frame [ text := "GenI Debugger - " ++ btype ++ " edition"+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 ]@@ -623,44 +640,53 @@ , clientSize := bigSize ] notebookSetSelection nb oldCount >> return ()+ -- -- generation step 1- (initStuff, initWarns) <- initGeni pstRef semInput- let (cand,_) = unzip $ B.inCands initStuff- -- continuation for tree assembly tab- let step3 results stats = do- resPnl <- BG.summaryPnl builderGui pstRef 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 config- -- automata tab- mAutPnl <- if hasOpt Polarised config- then Just <$> myPolarityGui nb autstuff- else return Nothing- -- generation step 2.B (start the generator for each path)- debugPnl <- BG.debuggerPnl builderGui pstRef nb input2 btype step3- let mAutTab = tab "automata" <$> mAutPnl- debugTab = tab "tree assembly" debugPnl- addTabs $ catMaybes [ mAutTab, Just debugTab ]- -- inputs tab- inpPnl <- inputInfoGui nb config semInput- -- lexical selection tab- pst <- readIORef pstRef- (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)+ minit <- runErrorT $ initGeni pst wrangler (tcSem tc)+ case minit of+ Left err -> do+ msgPnl <- messageGui nb 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, -1) -- all true?+ 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
src/NLP/GenI/GuiHelper.hs view
@@ -15,52 +15,58 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} module NLP.GenI.GuiHelper where -import Control.Applicative ( (<$>) )-import Control.Exception hiding ( bracket )-import Control.Monad ( unless, forM_ )-import Control.Monad.State.Strict ( execStateT, runState )-import Data.Array ( (!), listArray )-import Data.GraphViz.Exception ( GraphvizException(..) )-import Data.IORef-import Data.Text ( Text )-import Prelude hiding ( catch )-import System.Directory-import System.FilePath ((<.>),(</>),dropExtensions)-import System.Process (runProcess)-import qualified Control.Monad as Monad-import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.Text.IO as T+import Control.Applicative ((<$>))+import Control.Exception hiding (bracket)+import Control.Monad (forM_, unless)+import qualified Control.Monad as Monad+import Control.Monad.State.Strict (execStateT, runState)+import Data.Array (listArray, (!))+import Data.IORef+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Prelude hiding (catch)+import System.Directory+import System.FilePath (dropExtensions, (<.>), (</>))+import System.Process (runProcess) -import Graphics.UI.WX+import Data.GraphViz.Exception (GraphvizException (..))+import Graphics.UI.WX+import Graphics.UI.WXCore (textCtrlSetEditable) -import NLP.GenI-import NLP.GenI.Automaton (numStates, numTransitions)-import NLP.GenI.Builder (queryCounter, num_iterations, chart_size, num_comparisons)-import NLP.GenI.Configuration ( Params(..), MetricsFlg(..), setFlagP, getFlagP- , hasOpt, Optimisation(..)- , MacrosFlg(..), ViewCmdFlg(..) )-import NLP.GenI.General (dropTillIncluding, ePutStrLn)-import NLP.GenI.Parser ( geniTagElems, parseFromFile )-import NLP.GenI.GeniShow ( geniShowText )-import NLP.GenI.Graphviz-import NLP.GenI.GraphvizShow (GvItem(..), gvItemSetFlag, gvItemLabel)-import NLP.GenI.GraphvizShowPolarity ()-import NLP.GenI.Lexicon-import NLP.GenI.Polarity (PolAut, AutDebug, suggestPolFeatures)-import NLP.GenI.Pretty-import NLP.GenI.Statistics-import NLP.GenI.Tag ( idname, mapBySem, TagElem(ttrace, tinterface), TagItem(tgIdName), tagLeaves )-import NLP.GenI.TreeSchema ( showLexeme )-import NLP.GenI.Warning-import qualified NLP.GenI.Builder as B+import NLP.GenI+import NLP.GenI.Automaton (numStates, numTransitions)+import NLP.GenI.Builder (chart_size, num_comparisons,+ num_iterations, queryCounter)+import qualified NLP.GenI.Builder as B+import NLP.GenI.Configuration (Params (..))+import NLP.GenI.Flag+import NLP.GenI.General (dropTillIncluding, ePutStrLn)+import NLP.GenI.GeniShow (geniShowText)+import NLP.GenI.Graphviz+import NLP.GenI.GraphvizShow+import NLP.GenI.GraphvizShowPolarity ()+import NLP.GenI.Lexicon+import NLP.GenI.Parser (geniTagElems, parseFromFile)+import NLP.GenI.Polarity (AutDebug, PolAut,+ suggestPolFeatures)+import NLP.GenI.Pretty+import NLP.GenI.Statistics+import NLP.GenI.Tag (TagElem (ttrace, tinterface),+ TagItem (tgIdName), idname,+ mapBySem, tagLeaves)+import NLP.GenI.TreeSchema (showLexeme)+import NLP.GenI.Warning -- ---------------------------------------------------------------------- -- Types@@ -145,7 +151,9 @@ case suggestPolFeatures xs of [] -> "None! :-(" fs -> T.unwords fs- addPolFeats fs = if hasOpt Polarised config then polFeats : fs else fs+ addPolFeats fs = if hasOpt Polarised (geniFlags config)+ then polFeats : fs+ else fs lexWarnings = concatMap showGeniWarning . fromGeniWarnings . sortWarnings $ warns warning = T.unlines $ filter (not . T.null) (addPolFeats lexWarnings) -- side panel@@ -216,14 +224,14 @@ gvRef <- newGvRef () "automata" setGvDrawables gvRef $ concatMap toItem xs ++ [finalItem] graphvizGui f "polarity" gvRef- where+ where toItem (pkey, a1, a2) = [ it (pretty pkey) a1 , it (pretty pkey <+> "pruned") a2 ] finalItem = it "final" final it n a = GvItem (lab n a) () a lab n a = (n <+>) $ parens $- pretty (numStates a) <> "st " <>- pretty (numTransitions a) <> "tr"+ pretty (numStates a) <> "st " <>+ pretty (numTransitions a) <> "tr" -- ---------------------------------------------------------------------- -- Helpers@@ -315,8 +323,8 @@ runViewTag :: Params -> String -> IO () runViewTag params drName =- maybeOrWarn warnTf (getFlagP MacrosFlg params) $ \f ->- maybeOrWarn warnVc (getFlagP ViewCmdFlg params) $ \cmd ->+ maybeOrWarn warnTf (getFlag MacrosFlg params) $ \f ->+ maybeOrWarn warnVc (getFlag ViewCmdFlg params) $ \cmd -> actuallyView f cmd where warnTf = "Warning: No tree schema file specified (runViewTag)"@@ -340,18 +348,18 @@ -> IO (Layout, GvUpdater) data GraphvizShow (GvItem flg itm) => Debugger st flg itm = Debugger- { dBuilder :: B.Builder st itm Params+ { dBuilder :: B.Builder st itm -- ^ builder to use- , dToGv :: st -> [GvItem flg itm]+ , dToGv :: st -> [GvItem flg itm] -- ^ function to convert a Builder state into lists of items -- and their labels, the way graphvizGui likes it , dControlPnl :: DebuggerItemBar st flg itm -- ^ function returning a control panel configuring -- how you want the currently selected item in the debugger -- to be displayed- , dCacheDir :: FilePath+ , dCacheDir :: FilePath -- ^ graphviz cache directory- , dNext :: [GeniResult] -> Statistics -> IO ()+ , dNext :: [GeniResult] -> Statistics -> IO () } -- | A generic graphical debugger widget for GenI, including@@ -379,13 +387,14 @@ -- you might want to decorate the type with some other information debuggerPanel :: GraphvizShow (GvItem flg itm) => Debugger st flg itm- -> ProgStateRef+ -> ProgState -> Window a -- ^ parent window -> B.Input+ -> Maybe Params -- ^ test case parameters -> IO Layout-debuggerPanel (Debugger {..}) pstRef f input = do- config <- (setMetrics . pa) <$> readIORef pstRef- let (initS, initStats) = initBuilder input config+debuggerPanel (Debugger {..}) pst f input newPa = do+ let config = setMetrics pst+ let (initS, initStats) = initBuilder input (flags config) p <- panel f [] -- --------------------------------------------------------- -- item viewer: select and display an item@@ -461,13 +470,13 @@ initBuilder = B.init dBuilder nextStep = B.step dBuilder allSteps = B.stepAll dBuilder- setMetrics = setFlagP MetricsFlg B.defaultMetricNames+ setMetrics = setFlag MetricsFlg B.defaultMetricNames -- builder stateToGv itemBar f config_ input cachedir = do callNext d stats st = do done <- varGet d unless done $ do varSet d True- results <- extractResults pstRef dBuilder st+ results <- extractResults pst newPa dBuilder st dNext results stats -- --------------------------------------------------------------------@@ -534,8 +543,8 @@ gvOnSelect :: IO () -> (a -> IO ()) -> GraphvizGuiSt st (GvItem f a) -> IO () gvOnSelect onNothing onJust gvSt = case Map.lookup sel things of- Just (GvItem _ _ s) -> onJust s- _ -> onNothing+ Just (GvItem _ _ s) -> onJust s+ _ -> onNothing where sel = gvsel gvSt things = gvitems gvSt@@ -552,8 +561,8 @@ addGvHandler gvref h = do gvSt <- readIORef gvref let newH = case gvhandler gvSt of- Nothing -> h- Just oldH -> \g -> oldH g >> h g+ Nothing -> h+ Just oldH -> \g -> oldH g >> h g setGvHandler gvref (Just newH) type GvIO st d = IO (Layout, GraphvizGuiRef st d, GvUpdater)@@ -720,10 +729,10 @@ exists <- doesFileExist graphicFile -- we only call graphviz if the image is not in the cache if exists- then return (GvCreated graphicFile)- else case Map.lookup sel drawables of- Nothing -> return (GvNoSuchItem sel)- Just it -> create it `catch` handler+ then return (GvCreated graphicFile)+ else case Map.lookup sel drawables of+ Nothing -> return (GvNoSuchItem sel)+ Just it -> create it `catch` handler -- | Directory to dump image files in so that we can avoid regenerating them. -- If the directory already exists, we can just delete all the files in it.@@ -735,10 +744,10 @@ let cachedir = mainCacheDir </> cachesubdir cExists <- doesDirectoryExist cachedir if cExists- then do- contents <- filter notJunk <$> getDirectoryContents cachedir- mapM_ (removeFile . (cachedir </>)) contents- else createDirectory cachedir+ then do+ contents <- filter notJunk <$> getDirectoryContents cachedir+ mapM_ (removeFile . (cachedir </>)) contents+ else createDirectory cachedir where notJunk = (`notElem` [".", ".."]) @@ -771,15 +780,16 @@ maybeSaveAsFile f msg = do fsel <- fileSaveDialog f False True "Save to" anyFile "" "" case fsel of- Nothing -> return ()- Just file -> T.writeFile file msg+ Nothing -> return ()+ Just file -> T.writeFile file msg -- | A message panel for use by the Results gui panels. messageGui :: Window a -> Text -> IO Layout messageGui f msg = do p <- panel f [] -- sw <- scrolledWindow p [scrollRate := sz 10 10 ]- t <- textCtrl p [ text := T.unpack msg, enabled := False ]+ t <- textCtrl p [ text := T.unpack msg ]+ textCtrlSetEditable t False return $ fill $ container p $ column 1 [ fill (widget t) ] gvCACHEDIR :: IO String
src/NLP/GenI/MainGui.hs view
@@ -18,40 +18,44 @@ {-# LANGUAGE CPP #-} module NLP.GenI.MainGui where -import Data.IORef(newIORef)-import Data.Typeable( Typeable )-import Data.Version ( showVersion )-import System.Environment(getArgs, getProgName)+import Data.IORef (newIORef)+import Data.Typeable (Typeable)+import Data.Version (showVersion)+import System.Environment (getArgs, getProgName) -import Paths_geni_gui ( version )-import NLP.GenI ( ProgState(..), emptyProgState )-import NLP.GenI.Configuration- ( treatArgs, optionsForStandardGenI, processInstructions, usage- , optionsSections, hasFlagP- , BatchDirFlg(..), DumpDerivationFlg(..), FromStdinFlg(..)- , HelpFlg(..), VersionFlg(..)- , readGlobalConfig, setLoggers- )-import NLP.GenI.Console(consoleGeni)-import NLP.GenI.Gui(guiGeni)+import NLP.GenI (ProgState (..), defaultCustomSem,+ emptyProgState)+import NLP.GenI.Configuration (optionsForStandardGenI,+ optionsSections,+ processInstructions,+ readGlobalConfig, setLoggers,+ treatArgs, usage)+import NLP.GenI.Console (consoleGeni)+import NLP.GenI.Flag+import NLP.GenI.Gui (guiGeni)+import NLP.GenI.LexicalSelection+import Paths_geni_gui (version) main :: IO ()-main = getArgs- >>= treatArgs optionsForStandardGenI- >>= processInstructions- >>= (mainWithState . emptyProgState)+main = do+ stuff <- processInstructions+ =<< treatArgs optionsForStandardGenI+ =<< getArgs+ let pst = emptyProgState stuff+ wrangler <- defaultCustomSem pst+ mainWithState pst wrangler -mainWithState :: ProgState -> IO ()-mainWithState pst = do+mainWithState :: ProgState -> CustomSem sem -> IO ()+mainWithState pst wrangler = do pname <- getProgName maybe (return ()) setLoggers =<< readGlobalConfig pstRef <- newIORef pst let has :: (Typeable f, Typeable x) => (x -> f) -> Bool- has = flip hasFlagP (pa pst)+ has = flip hasFlag pst mustRunInConsole = has DumpDerivationFlg || has FromStdinFlg || has BatchDirFlg case () of _ | has HelpFlg -> putStrLn (usage optionsSections pname) | has VersionFlg -> putStrLn ("GenI " ++ showVersion version)- | mustRunInConsole -> consoleGeni pstRef- | otherwise -> guiGeni pstRef+ | mustRunInConsole -> consoleGeni pstRef wrangler+ | otherwise -> guiGeni pstRef wrangler
src/NLP/GenI/Simple/SimpleGui.hs view
@@ -20,52 +20,58 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module NLP.GenI.Simple.SimpleGui where -import Control.Applicative ( (<$>) )-import Control.Arrow ( (***) )-import Data.IORef-import Data.List ( sort, partition )-import Data.Maybe ( fromMaybe )-import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL+import Control.Applicative ((<$>))+import Control.Arrow ((***))+import Control.Monad.Trans.Error+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 as GV import qualified Data.GraphViz.Attributes.Complete as GV-import Graphics.UI.WX+import Graphics.UI.WX -import NLP.GenI- ( ProgStateRef, ProgState(pa), runGeni- , GeniResults(..) , GeniResult(..)- , GeniSuccess(..), GeniError(..), isSuccess- )-import NLP.GenI.Configuration ( Params(..) )-import NLP.GenI.FeatureStructure ( AvPair(..) )-import NLP.GenI.General ( snd3, buckets )-import NLP.GenI.GeniVal ( mkGConstNone, GeniVal )-import NLP.GenI.Graphviz ( GraphvizShow(..), gvUnlines )-import NLP.GenI.GraphvizShow- ( graphvizShowDerivation, GvItem(..)- , gvItemSetFlag, GNodeHighlights, Highlights )-import NLP.GenI.GuiHelper- ( messageGui, tagViewerGui, maybeSaveAsFile, debuggerPanel- , Debugger (..)- , DebuggerItemBar, GvIO, newGvRef, GraphvizGuiSt(..), viewTagWidgets- , XMGDerivation(getSourceTrees), modifyGvItems- )-import NLP.GenI.Morphology (LemmaPlus(..))-import NLP.GenI.Polarity hiding ( finalSt )-import NLP.GenI.Pretty-import NLP.GenI.Semantics ( SemInput )-import NLP.GenI.Simple.SimpleBuilder- ( simpleBuilder, SimpleStatus, SimpleItem(..), SimpleGuiItem(..)- , unpackResult ,step- , theResults, theAgenda, theHoldingPen, theChart, theTrash- )-import NLP.GenI.Statistics (Statistics, showFinalStats)-import NLP.GenI.Tag (dsChild, TagItem(..))-import NLP.GenI.TreeSchema ( GNode(..), GType(..) )-import qualified NLP.GenI.Builder as B-import qualified NLP.GenI.BuilderGui as BG+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@@ -82,14 +88,26 @@ , BG.debuggerPnl = simpleDebuggerTab twophase } -resultsPnl :: Bool -> ProgStateRef -> Window a -> SemInput -> IO ([GeniResult], Statistics, Layout, Layout)-resultsPnl twophase pstRef f semInput = do- (gresults, finalSt) <- runGeni pstRef semInput (simpleBuilder twophase)- let sentences = grResults gresults- stats = grStatistics gresults- (resultsL, _, _) <- realisationsGui pstRef f $ theResults finalSt- summaryL <- summaryGui pstRef f sentences stats- return (sentences, stats, summaryL, resultsL)+resultsPnl :: Bool+ -> ProgState+ -> CustomSem sem+ -> Window a+ -> TestCase sem+ -> IO ([GeniResult], Statistics, Layout, Layout)+resultsPnl twophase pst wrangler f tc = do+ mresults <- runErrorT $+ runGeni pst wrangler (simpleBuilder twophase) tc+ case mresults of+ Left err -> do+ (resultsL, _, _) <- realisationsGui pst f []+ summaryL <- messageGui f 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@@ -99,24 +117,25 @@ -- | Browser for derived/derivation trees, except if there are no results, we show a -- message box-realisationsGui :: ProgStateRef -> Window a -> [SimpleItem]+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 pstRef f resultsRaw = do- config <- pa <$> readIORef pstRef+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 :: ProgStateRef+summaryGui :: ProgState -> Window a -> [GeniResult]- -> Statistics -> IO Layout+ -> Statistics+ -> IO Layout summaryGui _ f results stats = do p <- panel f [] statsTxt <- textCtrl p [ text := showFinalStats stats ]@@ -134,7 +153,7 @@ (succeses, errors) = partitionGeniResult results taggedResults = concatMap sentences succeses resultBuckets = buckets snd taggedResults- sentences gr = map (\r -> (grOrigin gr, r)) (grRealisations gr)+ sentences x = map (\r -> (grOrigin x, r)) (grRealisations x) prettyBucket (s, xys) = s <+> parens instances where instances = if length ys == 1@@ -150,8 +169,9 @@ fromError (GeniError e) = e partitionGeniResult :: [GeniResult] -> ([GeniSuccess],[GeniError])-partitionGeniResult results = (map unSucc *** map unErr)- $ partition isSuccess results+partitionGeniResult results =+ (map unSucc *** map unErr) $+ partition isSuccess results where unSucc (GSuccess x) = x unSucc _ = error "NLP.GenI.Simple.SimpleGui unSucc"@@ -163,21 +183,21 @@ -- -------------------------------------------------------------------- simpleDebuggerTab :: Bool- -> ProgStateRef+ -> ProgState+ -> Maybe Params -> Window a -> B.Input -> String -> ([GeniResult] -> Statistics -> IO ()) -> IO Layout-simpleDebuggerTab twophase pstRef f input name job = do- config <- pa <$> readIORef pstRef- debuggerPanel (dbg config) pstRef f input+simpleDebuggerTab twophase pst newPa f input name job = do+ debuggerPanel dbg pst f input newPa where- dbg :: Params -> Debugger SimpleStatus Bool SimpleItem- dbg config = Debugger+ dbg :: Debugger SimpleStatus Bool SimpleItem+ dbg = Debugger { dBuilder = simpleBuilder twophase , dToGv = stToGraphviz- , dControlPnl = simpleItemBar config+ , dControlPnl = simpleItemBar (pa pst) , dNext = job , dCacheDir = name }@@ -223,6 +243,7 @@ let onUpdate = do status <- gvcore `fmap` readIORef gvRef set phaseTxt [ text := show (step status) ]+ onDetailsChk -- toggle the show features state return (lay, onUpdate) -- --------------------------------------------------------------------@@ -250,7 +271,7 @@ , glexeme = [] , gtype = Other , ganchor = False- , gaconstr = False+ , gaconstr = MaybeAdj , gorigin = "ERROR" } @@ -265,7 +286,7 @@ graphvizLabel (GvHeader _) = "" graphvizLabel g@(GvItem _ _ c) = gvUnlines $ graphvizLabel (highlightSimpleItem g)- : map TL.pack (siDiagnostic (siGuiStuff c))+ : map TL.fromStrict (siDiagnostic (siGuiStuff c)) graphvizParams = graphvizParams . highlightSimpleItem @@ -276,7 +297,8 @@ highlightSimpleItem :: GvItem Bool SimpleItem -> GvItem GNodeHighlights SimpleItemWrapper highlightSimpleItem (GvHeader h) = GvHeader h-highlightSimpleItem (GvItem l f it) = GvItem l (f, highlights) (SimpleItemWrapper it)+highlightSimpleItem (GvItem l f it) =+ GvItem l (f, highlights) (SimpleItemWrapper it) where highlights :: Highlights (GNode GeniVal) highlights n =@@ -284,7 +306,7 @@ then Just (GV.X11Color GV.Red) else Nothing -siToSentence :: SimpleItem -> T.Text +siToSentence :: SimpleItem -> T.Text siToSentence si = case unpackResult si of [] -> siIdname . siGuiStuff $ si