diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/geni-gui.cabal b/geni-gui.cabal --- a/geni-gui.cabal +++ b/geni-gui.cabal @@ -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 diff --git a/geni-gui.hs b/geni-gui.hs --- a/geni-gui.hs +++ b/geni-gui.hs @@ -17,4 +17,4 @@ module Main (module NLP.GenI.MainGui) where -import NLP.GenI.MainGui +import NLP.GenI.MainGui diff --git a/src/NLP/GenI/BuilderGui.hs b/src/NLP/GenI/BuilderGui.hs --- a/src/NLP/GenI/BuilderGui.hs +++ b/src/NLP/GenI/BuilderGui.hs @@ -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 } diff --git a/src/NLP/GenI/Graphviz.hs b/src/NLP/GenI/Graphviz.hs --- a/src/NLP/GenI/Graphviz.hs +++ b/src/NLP/GenI/Graphviz.hs @@ -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) diff --git a/src/NLP/GenI/GraphvizShow.hs b/src/NLP/GenI/GraphvizShow.hs --- a/src/NLP/GenI/GraphvizShow.hs +++ b/src/NLP/GenI/GraphvizShow.hs @@ -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 = diff --git a/src/NLP/GenI/GraphvizShowPolarity.hs b/src/NLP/GenI/GraphvizShowPolarity.hs --- a/src/NLP/GenI/GraphvizShowPolarity.hs +++ b/src/NLP/GenI/GraphvizShowPolarity.hs @@ -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 diff --git a/src/NLP/GenI/Gui.hs b/src/NLP/GenI/Gui.hs --- a/src/NLP/GenI/Gui.hs +++ b/src/NLP/GenI/Gui.hs @@ -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 diff --git a/src/NLP/GenI/GuiHelper.hs b/src/NLP/GenI/GuiHelper.hs --- a/src/NLP/GenI/GuiHelper.hs +++ b/src/NLP/GenI/GuiHelper.hs @@ -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 diff --git a/src/NLP/GenI/MainGui.hs b/src/NLP/GenI/MainGui.hs --- a/src/NLP/GenI/MainGui.hs +++ b/src/NLP/GenI/MainGui.hs @@ -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 diff --git a/src/NLP/GenI/Simple/SimpleGui.hs b/src/NLP/GenI/Simple/SimpleGui.hs --- a/src/NLP/GenI/Simple/SimpleGui.hs +++ b/src/NLP/GenI/Simple/SimpleGui.hs @@ -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