geni-gui (empty) → 0.22.1
raw patch · 14 files changed
+2907/−0 lines, 14 filesdep +GenIdep +arraydep +basebuild-type:Customsetup-changedbinary-added
Dependencies added: GenI, array, base, cabal-macosx, containers, directory, filepath, geni-gui, graphviz, hslogger, json, mtl, process, split, strict-io, text, utf8-string, wx, wxcore, yaml-light
Files
- LICENSE +340/−0
- Setup.hs +29/−0
- geni-gui.cabal +61/−0
- geni-gui.hs +20/−0
- macstuff/Info.plist +36/−0
- macstuff/wxmac.icns binary
- src/NLP/GenI/BuilderGui.hs +59/−0
- src/NLP/GenI/Graphviz.hs +149/−0
- src/NLP/GenI/GraphvizShow.hs +277/−0
- src/NLP/GenI/GraphvizShowPolarity.hs +101/−0
- src/NLP/GenI/Gui.hs +675/−0
- src/NLP/GenI/GuiHelper.hs +810/−0
- src/NLP/GenI/MainGui.hs +57/−0
- src/NLP/GenI/Simple/SimpleGui.hs +293/−0
+ LICENSE view
@@ -0,0 +1,340 @@+ GNU GENERAL PUBLIC LICENSE+ Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users. This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it. (Some other Free Software Foundation software is covered by+the GNU Library General Public License instead.) You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++ To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have. You must make sure that they, too, receive or can get the+source code. And you must show them these terms so they know their+rights.++ We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++ Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software. If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++ Finally, any free program is threatened constantly by software+patents. We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary. To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++ The precise terms and conditions for copying, distribution and+modification follow.++ GNU GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License. The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language. (Hereinafter, translation is included without limitation in+the term "modification".) Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++ 1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++ 2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) You must cause the modified files to carry prominent notices+ stating that you changed the files and the date of any change.++ b) You must cause any work that you distribute or publish, that in+ whole or in part contains or is derived from the Program or any+ part thereof, to be licensed as a whole at no charge to all third+ parties under the terms of this License.++ c) If the modified program normally reads commands interactively+ when run, you must cause it, when started running for such+ interactive use in the most ordinary way, to print or display an+ announcement including an appropriate copyright notice and a+ notice that there is no warranty (or else, saying that you provide+ a warranty) and that users may redistribute the program under+ these conditions, and telling the user how to view a copy of this+ License. (Exception: if the Program itself is interactive but+ does not normally print such an announcement, your work based on+ the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++ a) Accompany it with the complete corresponding machine-readable+ source code, which must be distributed under the terms of Sections+ 1 and 2 above on a medium customarily used for software interchange; or,++ b) Accompany it with a written offer, valid for at least three+ years, to give any third party, for a charge no more than your+ cost of physically performing source distribution, a complete+ machine-readable copy of the corresponding source code, to be+ distributed under the terms of Sections 1 and 2 above on a medium+ customarily used for software interchange; or,++ c) Accompany it with the information you received as to the offer+ to distribute corresponding source code. (This alternative is+ allowed only for noncommercial distribution and only if you+ received the program in object code or executable form with such+ an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it. For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable. However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++ 4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License. Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++ 5. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Program or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++ 6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++ 7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all. For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number. If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation. If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++ 10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission. For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this. Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++ NO WARRANTY++ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ 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+++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++ Gnomovision version 69, Copyright (C) year name of author+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the program+ `Gnomovision' (which makes passes at compilers) written by James Hacker.++ <signature of Ty Coon>, 1 April 1989+ Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs. If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library. If this is what you want to do, use the GNU Library General+Public License instead of this License.
+ Setup.hs view
@@ -0,0 +1,29 @@+{-# 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 Distribution.PackageDescription+import Distribution.MacOSX+import Distribution.Simple.Setup+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks+ { postInst = appBundleInstallHook [geniApp DoNotChase]+ , postBuild = appBundleBuildHook [geniApp DoNotChase]+ }++geniApp :: ChaseDeps -> MacApp+geniApp =+ MacApp "geni-gui"+ (Just "macstuff/wxmac.icns")+ (Just "macstuff/Info.plist")+ []+ []
+ geni-gui.cabal view
@@ -0,0 +1,61 @@+Name: geni-gui+Version: 0.22.1+License: GPL+License-file: LICENSE+Author: Carlos Areces and Eric Kow+Category: Natural Language Processing+Synopsis: GenI graphical user interface+Homepage: http://projects.haskell.org/GenI+Maintainer: geni-users@loria.fr+Build-Type: Custom+Cabal-Version: >=1.8+Extra-source-files:+ macstuff/Info.plist,+ macstuff/wxmac.icns++Library+ Exposed-Modules:+ NLP.GenI.BuilderGui+ NLP.GenI.Graphviz+ NLP.GenI.GraphvizShow+ NLP.GenI.GraphvizShowPolarity+ NLP.GenI.Gui+ NLP.GenI.GuiHelper+ NLP.GenI.MainGui+ NLP.GenI.Simple.SimpleGui + Other-Modules:+ Paths_geni_gui++ Hs-Source-Dirs: src+ Ghc-options: -Wall+ Ghc-prof-options: -auto-all++ Build-Depends: base >= 4 && < 5+ , GenI+ , cabal-macosx == 0.2.*+ , array+ , containers+ , directory+ , filepath+ , yaml-light+ , hslogger+ , json+ , mtl+ , process+ , split+ , utf8-string+ , strict-io+ , wx >= 0.12+ , wxcore+ , text+ , graphviz >= 2999.12 && < 2999.14++Executable geni-gui+ Main-Is: geni-gui.hs+ Hs-Source-Dirs: .++ Ghc-options: -Wall -rtsopts+ Ghc-prof-options: -auto-all+ Build-Depends: base >= 4 && < 5+ , GenI+ , geni-gui
+ geni-gui.hs view
@@ -0,0 +1,20 @@+-- 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.++module Main (module NLP.GenI.MainGui) where++import NLP.GenI.MainGui
+ macstuff/Info.plist view
@@ -0,0 +1,36 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">+<plist version="1.0">+<dict>+ <key>CFBundleDevelopmentRegion</key>+ <string>English</string>+ <key>CFBundleExecutable</key>+ <string>geni-gui</string>+ <key>CFBundleGetInfoString</key>+ <string>GenI</string>+ <key>CFBundleIconFile</key>+ <string>wxmac.icns</string>+ <key>CFBundleIdentifier</key>+ <string>fr.loria.geni</string>+ <key>CFBundleInfoDictionaryVersion</key>+ <string>6.0</string>+ <key>CFBundleLongVersionString</key>+ <string>(c) 2005-2009 LORIA</string>+ <key>CFBundleName</key>+ <string>GenI</string>+ <key>CFBundlePackageType</key>+ <string>APPL</string>+ <key>CFBundleShortVersionString</key>+ <string>0</string>+ <key>CFBundleSignature</key>+ <string>????</string>+ <key>CFBundleVersion</key>+ <string>0</string>+ <key>CSResourcesFileMapped</key>+ <true/>+ <key>LSRequiresCarbon</key>+ <true/>+ <key>NSHumanReadableCopyright</key>+ <string>Copyright 2005-2009 LORIA</string>+</dict>+</plist>
+ macstuff/wxmac.icns view
binary file changed (absent → 46234 bytes)
+ src/NLP/GenI/BuilderGui.hs view
@@ -0,0 +1,59 @@+-- GenI surface realiser+-- Copyright (C) 2005 Carlos Areces and Eric Kow+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License+-- as published by the Free Software Foundation; either version 2+-- of the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++{-# LANGUAGE RankNTypes #-}+module NLP.GenI.BuilderGui where++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)++-- | 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“+-- algorithm that remains in 2012-GenI. Diffrent algorithms may use different+-- chart items, and different debugger visualisations, hence this data structure+--+-- I hope one day to make a move towards implementing the fancier algorithms,+-- which is why I'm keeping around this infrastructure+data BuilderGui = BuilderGui+ { -- | 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+ -> IO ([GeniResult],Statistics,Layout,Layout)+ -- | Just a sentence summary tab (small part of the resultsPnl)+ , summaryPnl :: forall a+ . ProgStateRef+ -> Window a -- ^ parent+ -> [GeniResult]+ -> Statistics+ -> IO Layout+ , debuggerPnl :: forall a+ . ProgStateRef+ -> Window a -- ^ parent+ -> B.Input+ -> String -- ^ name of the builder algorithm+ -> ([GeniResult] -> Statistics -> IO ())+ -- ^ what to do when we get results+ -> IO Layout+ }
+ src/NLP/GenI/Graphviz.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}++{-+ 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.+-}++{- | 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 + to invoke graphviz and to convert graphs and trees to its input format.++ You can download this (open source) tool at+ <http://www.research.att.com/sw/tools/graphviz>+-}++module NLP.GenI.Graphviz+where++import Control.Arrow ( second )+import Data.GraphViz+import Data.GraphViz.Printing ( printIt )+import Data.GraphViz.Attributes.Complete++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 )++{- |+ Data structures which can be visualised with GraphViz should+ implement this class. Note the first argument to graphvizShowGraph is+ so that you can parameterise your show function (i.e. pass in+ flags to change the way you show particular object). Note+ that by default, all graphs are treated as directed graphs. You+ 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 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 _ = []++class GraphvizShowNode b where+ 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++-- | 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 x dotFile outputFile = do+ T.writeFile dotFile (printIt g)+ runGraphviz g Png outputFile+ where+ g = graphvizShowGraph x++-- ---------------------------------------------------------------------+-- useful utility functions+-- ---------------------------------------------------------------------++gvUnlines :: [Text] -> Text+gvUnlines = T.intercalate "\n"++-- ---------------------------------------------------------------------+-- some instances +-- ---------------------------------------------------------------------++instance GraphvizShow b => GraphvizShow (Maybe b) where+ graphvizShowAsSubgraph _ Nothing = []+ graphvizShowAsSubgraph p (Just b) = graphvizShowAsSubgraph p b++ graphvizLabel Nothing = ""+ graphvizLabel (Just b) = graphvizLabel b++ graphvizParams Nothing = []+ graphvizParams (Just b) = graphvizParams b++-- | 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. ++ 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+ something more specific, that would be cool.++ The prefix argument is interpreted as the name of the top node. Node+ names below are basically Gorn addresses (e.g. n0x2x3 means 3rd child of+ 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 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)]+ 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
@@ -0,0 +1,277 @@+-- GenI surface realiser+-- Copyright (C) 2009 Eric Kow+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License+-- as published by the Free Software Foundation; either version 2+-- of the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | 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 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(..) )++-- ----------------------------------------------------------------------+--+-- ----------------------------------------------------------------------++-- | Imagine some kind of menu system that displays a list of items+-- and displays the selected item+data GvItem flg itm = GvHeader T.Text -- ^ no actual item+ | GvItem T.Text flg itm++gvItemLabel :: GvItem a b -> T.Text+gvItemLabel (GvHeader h) = h+gvItemLabel (GvItem l _ _) = l++gvItemSetFlag :: f -> GvItem f a -> GvItem f a+gvItemSetFlag _ g@(GvHeader _) = g+gvItemSetFlag f2 (GvItem l _ x) = GvItem l f2 x++instance GraphvizShow a => GraphvizShow (GvItem () a) where+ graphvizShowAsSubgraph _ (GvHeader _ ) = []+ graphvizShowAsSubgraph p (GvItem _ () b) = graphvizShowAsSubgraph p b++ graphvizLabel (GvHeader _) = ""+ graphvizLabel (GvItem _ () b) = graphvizLabel b++ graphvizParams (GvHeader _) = []+ graphvizParams (GvItem _ () b) = graphvizParams b++instance Functor (GvItem flg) where+ fmap _ (GvHeader h) = GvHeader h+ fmap fn (GvItem l flg x) = GvItem l flg (fn x)++-- ----------------------------------------------------------------------+-- For GraphViz+-- ----------------------------------------------------------------------++type GNodeHighlights = (Bool, Highlights (GNode GeniVal))+type Highlights a = (a -> Maybe Color)++nullHighlighter :: Highlights a+nullHighlighter = const Nothing++addNullHighlighter :: GvItem Bool x -> GvItem GNodeHighlights x+addNullHighlighter (GvHeader h) = GvHeader h+addNullHighlighter (GvItem l f x) = GvItem l (f, nullHighlighter) x++instance GraphvizShow (GvItem Bool TagElem) where+ graphvizShowAsSubgraph p = graphvizShowAsSubgraph p . addNullHighlighter+ graphvizLabel = graphvizLabel . addNullHighlighter+ graphvizParams = graphvizParams . addNullHighlighter++instance TagItem t => GraphvizShow (GvItem GNodeHighlights t) where+ graphvizShowAsSubgraph _ (GvHeader _) = []+ graphvizShowAsSubgraph prefix (GvItem _ (sf, hfn) te) =+ [ gvShowTree (prefix `TL.append` "DerivedTree0")+ (fmap toDetails (tgTree te))+ ]+ where+ toDetails x = Details { ddetails = sf+ , dcolour = hfn x+ , dnode = x+ }++ graphvizLabel (GvHeader _) = ""+ graphvizLabel (GvItem _ _ te) =+ gvUnlines [ treename, semlist ]+ where+ -- we display the tree semantics as the graph label+ treename = "name: " `TL.append` TL.fromChunks [tgIdName te]+ semlist = "semantics: " `TL.append` gvShowSem (tgSemantics te)++ graphvizParams _ =+ [ GraphAttrs [ FontSize 10, RankSep [0.3] ]+ , NodeAttrs [ FontSize 10 ]+ , EdgeAttrs [ FontSize 10, ArrowHead normal ]+ ]++gvShowSem :: Sem -> TL.Text+gvShowSem = gvUnlines+ . map (TL.pack . unwords)+ . clumpBy length 72+ . words+ . prettyStr++-- ----------------------------------------------------------------------+-- Helper functions for the TagElem GraphvizShow instance+-- ----------------------------------------------------------------------++data Details n = Details+ { ddetails :: Bool+ , dcolour :: Maybe Color+ , dnode :: n+ }++instance GraphvizShowNode (Details (GNode GeniVal)) where+ -- compact -> (node, mcolour) -> String+ graphvizShowNode prefix dn =+ DotNode prefix (body : shapeParams ++ colorParams)+ where+ -- attributes+ filledParam = Style [SItem Filled []]+ fillcolorParam = FillColor (X11Color LemonChiffon)+ shapeRecordParam = Shape Record+ shapePlaintextParam = Shape PlainText+ --+ colorParams = FontColor <$> maybeToList (dcolour dn)+ shapeParams = if ddetails dn+ then [ shapeRecordParam, filledParam, fillcolorParam ]+ else [ shapePlaintextParam ]+ -- content+ gn = dnode dn+ stub = showGnStub gn+ extra = showGnDecorations gn+ summary = if TL.null extra+ then FieldLabel stub+ else FlipFields [ FieldLabel stub, FieldLabel extra ]+ body = Label $+ if not (ddetails dn)+ then (StrLabel (graphvizShow_ gn))+ else RecordLabel [ FlipFields $+ [ summary+ , FieldLabel . showFs $ gup gn+ ] ++ maybeFs (gdown gn)+ ]+ where+ showFs = gvUnlines . map graphvizShow_+ maybeFs fs = if null fs then [] else [FieldLabel (showFs fs)]++instance GraphvizShowString (GNode GeniVal) where+ graphvizShow gn =+ stub `TL.append` extra+ where+ stub = showGnStub gn+ extra = showGnDecorations gn++instance GraphvizShowString (AvPair GeniVal) where+ graphvizShow (AvPair a v) = TL.fromChunks [a, ":"] `TL.append` graphvizShow_ v++instance GraphvizShowString GeniVal where+ graphvizShow g =+ case (gLabel g, gConstraints g) of+ (Nothing, Nothing) -> "?_"+ (Nothing, Just cs) -> constraints cs+ (Just l, Nothing) -> plainVar l+ (Just l, Just cs) -> TL.concat [plainVar l, "/", constraints cs]+ where+ plainVar l = '?' `TL.cons` TL.fromChunks [l]+ constraints cs = TL.intercalate "!" $ map TL.fromChunks [fromFL cs]++showGnDecorations :: GNode GeniVal -> TL.Text+showGnDecorations gn =+ case gtype gn of+ Subs -> "↓"+ Foot -> "*"+ _ -> if gaconstr gn then "ᴺᴬ" else ""++showGnStub :: GNode GeniVal -> TL.Text+showGnStub gn =+ TL.intercalate ":" $ filter (not . TL.null) [ cat, idx, lexeme ]+ where+ cat = case getGnVal gup "cat" gn of+ Nothing -> ""+ Just v -> graphvizShow_ v+ getIdx f = case getGnVal f "idx" gn of+ Nothing -> ""+ Just v -> if isConst v then graphvizShow_ v else ""+ idxT = getIdx gup+ idxB = getIdx gdown+ idx = tackOn "." idxT idxB+ --+ lexeme = TL.intercalate "!" [ TL.fromChunks [n] | n <- glexeme gn ]++getGnVal :: (GNode GeniVal -> Flist GeniVal)+ -> T.Text+ -> GNode GeniVal+ -> Maybe GeniVal+getGnVal getFeat attr gn =+ listToMaybe [ v | AvPair a v <- getFeat gn, a == attr ]++-- | @x `tackOn p` y@` is @TL.concat [x, p, y]@ if @y@ is not null+-- otherwise is just x+tackOn :: TL.Text -> TL.Text -> TL.Text -> TL.Text+tackOn p x y = if TL.null y then x else TL.concat [ x, p, y ]++graphvizShow_ :: GraphvizShowString a => a -> TL.Text+graphvizShow_ = graphvizShow++-- ----------------------------------------------------------------------+-- Derivation tree+-- ----------------------------------------------------------------------++graphvizShowDerivation :: TagDerivation -> [DotSubGraph TL.Text]+graphvizShowDerivation = maybeToList . derivationToGv++derivationToGv :: TagDerivation -> Maybe (DotSubGraph TL.Text)+derivationToGv deriv =+ if null histNodes+ then Nothing+ else Just $ DotSG False Nothing $ DotStmts atts [] nodes edges+ where+ atts = [ NodeAttrs [ Shape PlainText ]+ , EdgeAttrs [ ArrowHead noArrow ]+ ]+ nodes = map mkNode histNodes+ edges = mapMaybe mkEdge deriv+ --+ histNodes = reverse $ nub $ concatMap (\d -> dsChild d : maybeToList (dsParent d)) deriv+ mkNode n =+ DotNode (gvDerivationLab n) [ Label . StrLabel $ label n ]+ mkEdge ds = do+ p <- dsParent ds+ return $ DotEdge (gvDerivationLab p)+ (gvDerivationLab (dsChild ds))+ (edgeStyle ds)+ edgeStyle (AdjunctionStep {}) = [Style [SItem Dashed []]]+ edgeStyle _ = []+ label n =+ case T.splitOn ":" n of+ name:fam:tree:_ -> TL.fromChunks [ name <> ":" <> fam <> "\n" <> tree ]+ _ -> TL.fromChunks [n] `TL.append` " (geni/gv ERROR)"++gvDerivationLab :: T.Text -> TL.Text+gvDerivationLab xs = "Derivation" `TL.append` gvMunge xs++-- | Node names can't have hyphens in them+gvMunge :: T.Text -> TL.Text+gvMunge = TL.fromChunks . T.split (`elem` ":-") . T.replace "." "x"
+ src/NLP/GenI/GraphvizShowPolarity.hs view
@@ -0,0 +1,101 @@+-- GenI surface realiser+-- Copyright (C) 2005 Carlos Areces and Eric Kow+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License+-- as published by the Free Software Foundation; either version 2+-- of the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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 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)++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+ []++ --+ 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++gvShowState :: [PolState] -> TL.Text -> PolState -> DotNode TL.Text+gvShowState fin stId 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++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)
+ src/NLP/GenI/Gui.hs view
@@ -0,0 +1,675 @@+-- GenI surface realiser+-- Copyright (C) 2005 Carlos Areces and Eric Kow+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License+-- as published by the Free Software Foundation; either version 2+-- of the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+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 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++-- Main Gui++guiGeni :: ProgStateRef -> IO()+guiGeni pstRef = start (mainGui pstRef)++mainGui :: ProgStateRef -> IO ()+mainGui pstRef = do+ pst <- readIORef pstRef+ -- Top Window+ f <- frame [text := "Geni Project"]+ -- create statusbar field+ status <- statusField []+ -- create the file menu+ fileMen <- menuPane [text := "&File"]+ loadMenIt <- menuItem fileMen [text := "&Open files or configure GenI"]+ quitMenIt <- menuQuit fileMen [text := "&Quit"]+ set quitMenIt [on command := close f ]+ -- create the help menu+ helpMen <- menuPane [text := "&Help"]+ aboutMeIt <- menuAbout helpMen [help := "About"]+ -- Tie the menu to this window+ set f [ statusBar := [status]+ , menuBar := [fileMen, helpMen]+ -- put the menu event handler for an about box on the frame.+ , on (menu aboutMeIt) := infoDialog f "About GenI"+ ("The GenI generator " ++ showVersion version +++ ".\nhttp://projects.haskell.org/GenI" )+ -- event handler for the tree browser+ -- , on (menu gbrowserMenIt) := do { loadEverything pstRef; treeBrowserGui pstRef }+ ]+ -- -----------------------------------------------------------------+ -- buttons+ -- -----------------------------------------------------------------+ let config = pa pst+ hasSem = hasFlagP TestSuiteFlg config+ -- Target Semantics+ testSuiteChoice <- choice f [ selection := 0, enabled := hasSem ]+ tsTextBox <- textCtrl f [ wrap := WrapWord+ , clientSize := sz 400 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)+ 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 ]+ -- Generate and Debug+ let genfn = doGenerate f pstRef tsTextBox detectPolsTxt rootFeatTxt+ pauseOnLexChk <- checkBox f [ text := "Inspect lex", tooltip := "Affects debugger only" ]+ debugBt <- button f [ text := "Debug"+ , on command := get pauseOnLexChk checked >>= genfn True ]+ genBt <- button f [text := "Generate", on command := genfn False False ]+ quitBt <- button f [ text := "Quit",+ on command := close f]+ -- -----------------------------------------------------------------+ -- optimisations+ -- -----------------------------------------------------------------+ let setBuilder b = modifyIORef pstRef . modifyParams+ $ \p -> p { builderType = b }+ initialSelection = case builderType config of+ SimpleBuilder -> 0+ SimpleOnePhaseBuilder -> 1+ algoChoiceBox <- radioBox f Vertical (map show mainBuilderTypes) []+ setSelection algoChoiceBox mainBuilderTypes initialSelection setBuilder+ polChk <- optCheckBox f pstRef polarisedBio+ useSemConstraintsChk <- optCheckBox f pstRef semConstraintBio+ -- -----------------------------------------------------------------+ -- layout; packing it all together+ -- -----------------------------------------------------------------+ -- set any last minute handlers, run any last minute functions+ let myWidgets = MainWidgets+ { f = f+ , macrosFileLabel = macrosFileLabel+ , lexiconFileLabel = lexiconFileLabel+ , testSuiteChoice = testSuiteChoice+ , testCaseChoice = testCaseChoice+ , tsTextBox = tsTextBox+ }+ onLoad = mainOnLoad pstRef myWidgets+ set loadMenIt [ on command := configGui pstRef onLoad ]+ onLoad+ --+ let labeledRow l w = row 1 [ label l, hfill (widget w) ]+ let gramsemBox = boxed "Files last loaded" $+ hfill $ column 1+ [ labeledRow "trees:" macrosFileLabel+ , labeledRow "lexicon:" lexiconFileLabel+ ]+ optimBox = --boxed "Optimisations " $ -- can't used boxed with wxwidgets 2.6 -- bug?+ column 5 [ label "Algorithm"+ , dynamic $ widget algoChoiceBox+ , label "Optimisations"+ , dynamic $ widget polChk+ , dynamic $ widget useSemConstraintsChk+ ]+ set f [layout := column 5 [ gramsemBox+ , row 5 [ fill $ -- boxed "Input Semantics" $+ hfill $ column 5+ [ labeledRow "test suite: " testSuiteChoice+ , labeledRow "test case: " testCaseChoice+ , fill $ widget tsTextBox+ , row 1 [ label "detect pols: "+ , hfill (widget detectPolsTxt)+ , glue+ , label "root feature: "+ , hfill (widget rootFeatTxt)+ ]+ ]+ , vfill optimBox ]+ -- ----------------------------- Generate and quit+ , row 1 [ widget quitBt+ , hfloatRight $ row 5 [ widget pauseOnLexChk, widget debugBt, widget genBt ]] ]+ -- , clientSize := sz 625 325+ , on closing := exitWith ExitSuccess+ ]++data MainWidgets = MainWidgets+ { f :: Frame ()+ , macrosFileLabel :: StaticText ()+ , lexiconFileLabel :: StaticText ()+ , testSuiteChoice :: Choice ()+ , testCaseChoice :: Choice ()+ , tsTextBox :: TextCtrl ()+ }++mainOnLoad :: ProgStateRef -> MainWidgets -> IO ()+mainOnLoad pstRef (MainWidgets {..}) = do+ cfg <- pa `fmap` 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 ]+ -- 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)++-- ----------------------------------------------------------------------+-- Toggling optimisations+-- ----------------------------------------------------------------------++-- | optimisation or pessimisation?+data OptType = Opti | Pessi++data OptBio = OptBio+ { odType :: OptType+ , odOpt :: Optimisation+ , odShortTxt :: String -- ^ confusing detail: always describes an optimisation+ -- (so it says the straightforward thing for optimisations+ -- but the opposite meaning for pessimisations)+ , odToolTip :: String -- ^ see confusing detail above+ }++polarisedBio :: OptBio+polarisedBio = OptBio Opti Polarised+ "Polarities"+ "Use the polarity optimisation"++semConstraintBio :: OptBio+semConstraintBio = OptBio Pessi NoConstraints+ "Sem constraints"+ "Use any sem constraints the user provides"++optBios :: [OptBio]+optBios = [ polarisedBio, semConstraintBio ]++-- | Note the following point about pessimisations: An pessimisation+-- disables a default behaviour which is assumed to be "optimisation". But of+-- course we don't want to confuse the GUI user, so we confuse the programmer+-- instead: Given an pessimisation DisableFoo, we have a check box UseFoo. If+-- UseFoo is checked, we remove DisableFoo from the list; if it is unchecked, we+-- add it to the list. This is the opposite of the default behaviour, but the+-- result, I hope, is intuitive for the user.+optCheckBox :: Window a -> ProgStateRef -> OptBio -> IO (CheckBox ())+optCheckBox f pstRef od = do+ config <- pa <$> readIORef pstRef+ chk <- checkBox f [ checked := flippy (hasOpt o config)+ , text := odShortTxt od+ , tooltip := odToolTip od+ ]+ set chk [ on command := onCheck chk ]+ return chk+ where+ o = odOpt od+ flippy = case odType od of+ Opti -> id+ Pessi -> not+ onCheck chk = do+ isChecked <- get chk checked+ config <- pa <$> readIORef pstRef+ let modopt = if flippy isChecked then (o:) else delete o+ newopts = nub . modopt $ getListFlagP OptimisationsFlg config+ modifyIORef pstRef . modifyParams $ setFlagP OptimisationsFlg newopts++-- --------------------------------------------------------------------+-- Loading files+-- --------------------------------------------------------------------++-- | Load the given test suite and update the GUI accordingly.+-- This is used when you first start the graphical interface+-- or when you run the configuration menu.+loadTestSuiteAndRefresh :: (Textual a, Selecting b, Selection b, Items b String)+ => Window w+ -> ProgStateRef+ -> 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)+ case msuite of+ Left e -> errorDialog f ("Error reading test suite " ++ suitePath) $ show (e :: SomeException)+ Right s -> onTestSuiteLoaded f s mcs mcase widgets++-- | Helper for 'loadTestSuiteAndRefresh'+onTestSuiteLoaded :: (Textual a, Selecting b, Selection b, Items b String)+ => Window w+ -> [TestCase] -- ^ loaded suite+ -> Maybe [Text] -- ^ subset of test cases to select (instructions)+ -> Maybe Text -- ^ particular test case to focus on+ -> (a, b) -- ^ test suite text and case selector widgets+ -> IO ()+onTestSuiteLoaded f suite mcs mcase (tsBox, caseChoice) = do+ -- if the instructions specify a set of cases, we hide the cases that aren't mentioned+ let suiteCases = case filter (\c -> tcName c `elem` fromMaybe [] mcs) suite of+ [] -> suite+ res -> res+ -- handler for selecting a test case+ unless (null suiteCases) $ do+ initial <- getInitialSelection mcase suiteCases+ set caseChoice [ items := zipWith numfn [1..] suiteCases ]+ setSelection caseChoice suiteCases initial setTsBox+ where+ -- we number the cases for easy identification, putting+ -- a star to highlight the selected test case (if available)+ numfn :: Int -> TestCase -> String+ numfn n t = concat [ if hasName (fromMaybe "" mcase) t then "* " else ""+ , show n+ , ". "+ , T.unpack (tcName t)+ ]+ -- first case selected is either specified+ getInitialSelection Nothing _ = return 0+ getInitialSelection (Just n) tcases =+ case findIndex (hasName n) tcases of+ Nothing -> do+ errorDialog f "" ("No such test case: " ++ T.unpack n)+ return 0+ Just i -> return i+ hasName name tc = tcName tc == name+ --+ setTsBox (TestCase {..}) =+ set tsBox [ text := geniShow (toSemInputString tcSem tcSemString) ]++-- --------------------------------------------------------------------+-- Configuration+-- --------------------------------------------------------------------++-- | 'configGui' @pstRef loadFn@ provides the configuration GUI. The continuation+-- @loadFn@ tells us what to do when the user closes this window.+configGui :: ProgStateRef -> IO () -> IO ()+configGui pstRef loadFn = do+ pst <- readIORef pstRef+ let config = pa pst+ --+ f <- frame []+ p <- panel f []+ nb <- notebook p []+ let browseTxt = "Browse"+ --+ let fakeBoxed title lst = hstretch $ column 3 $ map hfill $+ [ hrule 1 , alignRight $ label title, vspace 5 ]+ ++ map hfill lst+ let longSize = sz 20 (25 :: Int)+ -- -----------------------------------------------------------------+ -- basic options tab+ -- -----------------------------------------------------------------+ pbas <- panel nb []+ -- files loaded (labels)+ macrosFileLabel <- staticText pbas [ text := getListFlagP MacrosFlg config ]+ lexiconFileLabel <- staticText pbas [ text := getListFlagP LexiconFlg config ]+ tsFileLabel <- staticText pbas [ text := getListFlagP TestSuiteFlg config ]+ -- "Browse buttons"+ macrosBrowseBt <- button pbas [ text := browseTxt ]+ lexiconBrowseBt <- button pbas [ text := browseTxt ]+ tsBrowseBt <- button pbas [ text := browseTxt ]+ -- root feature+ detectPolsTxt <- entry pbas+ [ text := maybe "" showPolarityAttrs+ (getFlagP DetectPolaritiesFlg config)+ , size := longSize ]+ rootFeatTxt <- entry pbas+ [ text := maybe "" prettyStr (getFlagP RootFeatureFlg config)+ , size := longSize ]+ let layFiles = [ row 1 [ label "trees:"+ , fill $ widget macrosFileLabel+ , widget macrosBrowseBt ]+ , row 1 [ label "lexicon:"+ , fill $ widget lexiconFileLabel+ , widget lexiconBrowseBt ]+ , row 1 [ label "test suite:"+ , fill $ widget tsFileLabel+ , widget tsBrowseBt ]+ , hspace 5+ , hfill $ vrule 1+ , row 3 [ label "detect polarities"+ , hglue+ , rigid $ widget detectPolsTxt ]+ , row 3 [ label "root features"+ , hglue+ , rigid $ widget rootFeatTxt ]+ ]+ -- the layout for the basic stuff+ let layBasic = dynamic $ container pbas $ -- boxed "Basic options" $+ hfloatLeft $ dynamic $ fill $ column 4 $ map (dynamic.hfill) layFiles+ -- -----------------------------------------------------------------+ -- advanced options tab+ -- -----------------------------------------------------------------+ padv <- panel nb []+ -- XMG tools+ viewCmdTxt <- entry padv+ [ tooltip := "Command used for XMG tree viewing"+ , text := getListFlagP ViewCmdFlg config ]+ let layXMG = fakeBoxed "XMG tools"+ [ row 3 [ label "XMG view command"+ , marginRight $ hfill $ widget viewCmdTxt ] ]+ -- morphology+ morphFileLabel <- staticText padv [ text := getListFlagP MorphInfoFlg config ]+ morphFileBrowseBt <- button padv [ text := browseTxt ]+ morphCmdTxt <- entry padv+ [ tooltip := "Commmand used for morphological generation"+ , text := getListFlagP MorphCmdFlg config ]+ let layMorph = fakeBoxed "Morphology"+ [ row 3 [ label "morph info:"+ , expand $ hfill $ widget morphFileLabel+ , widget morphFileBrowseBt ]+ , row 3 [ label "morph command"+ , (marginRight.hfill) $ widget morphCmdTxt ] ]+ -- put the whole darn thing together+ let layAdvanced = hfloatLeft $ container padv+ $ column 10 [ layXMG, layMorph ]+ -- -----------------------------------------------------------------+ -- browse button action+ --+ -- When the user clicks on a Browse button, an open file dialogue+ -- should pop up. It gets its value from the file label on its left+ -- (passed in as an argument), and updates said label when the user has+ -- made a selection.+ -- -----------------------------------------------------------------+ -- helper functions+ curDir <- getCurrentDirectory+ let onBrowse theLabel = do+ rawFilename <- get theLabel text+ let filename = makeRelative curDir rawFilename+ filetypes = [("Any file",["*","*.*"])]+ fsel <- fileOpenDialog f False True+ "Choose your file..." filetypes "" filename+ case fsel of+ -- if the user does not select any file there are no changes+ Nothing -> return ()+ Just file -> set theLabel [ text := makeRelative curDir file ]+ -- end onBrowse+ -- activate those "Browse" buttons+ let setBrowse w l = set w [ on command := onBrowse l ]+ setBrowse macrosBrowseBt macrosFileLabel+ setBrowse lexiconBrowseBt lexiconFileLabel+ setBrowse tsBrowseBt tsFileLabel+ setBrowse morphFileBrowseBt morphFileLabel+ -- -----------------------------------------------------------------+ -- config GUI layout+ -- -----------------------------------------------------------------+ let parseRF = parseFlagWithParsec "root features" geniFeats+ -- TODO: this is horrible! parseFlagWithParsec should be replaced with+ -- something safer+ onLoad+ = do macrosVal <- get macrosFileLabel text+ lexconVal <- get lexiconFileLabel text+ tsVal <- get tsFileLabel text+ --+ detectPolsVal <- get detectPolsTxt text+ rootCatVal <- get rootFeatTxt text+ --+ viewVal <- get viewCmdTxt text+ --+ morphCmdVal <- get morphCmdTxt text+ morphInfoVal <- get morphFileLabel text+ --+ let maybeSet fl fn x =+ if null x then deleteFlagP fl else setFlagP 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)+ . maybeSet RootFeatureFlg parseRF rootCatVal+ . maybeSetStr ViewCmdFlg viewVal+ . maybeSetStr MorphCmdFlg morphCmdVal+ . maybeSetStr MorphInfoFlg morphInfoVal+ modifyIORef pstRef (modifyParams setConfig)+ loadFn+ -- end onLoad+ -- the button bar+ cancelBt <- button p [ text := "Cancel", on command := close f ]+ loadBt <- button p [ text := "Load", on command := do { onLoad; close f } ]+ --+ set f [ layout := dynamic $ fill $ container p $ column 0+ [ fill $ tabs nb [ tab "Basic" layBasic+ , tab "Advanced" layAdvanced ]+ , hfill $ row 1 [ hfloatLeft (widget cancelBt)+ , hfloatRight (widget loadBt) ]+ ]+ ]++-- --------------------------------------------------------------------+-- Generation+-- --------------------------------------------------------------------++-- | 'doGenerate' parses the target semantics, then calls the generator and+-- displays the result in a results gui (below).+doGenerate :: Textual tb => Window a -> ProgStateRef+ -> 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+ rootCatVal <- get rootFeatTxt text+ detectPolsVal <- get detectPolsTxt text+ --+ let maybeSet fl fn x =+ if null x then deleteFlagP fl else setFlagP fl (fn x)+ let setConfig = id+ . maybeSet RootFeatureFlg parseRF rootCatVal+ . setFlagP DetectPolaritiesFlg (readPolarityAttrs detectPolsVal)+ modifyIORef pstRef (modifyParams setConfig)+ minput <- do+ set sembox [ text :~ trim ]+ loadEverything pstRef+ parseSemInput <$> 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+ 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++resultsGui :: BG.BuilderGui -> ProgStateRef -> SemInput -> IO ()+resultsGui builderGui pstRef semInput = do+ -- results window+ f <- frame [ text := "Results"+ , fullRepaintOnResize := False+ , layout := stretch $ label "Generating..."+ , clientSize := sz 300 300+ ]+ p <- panel f []+ nb <- notebook p []+ pst <- readIORef pstRef+ -- input tab+ inputTab <- inputInfoGui nb (pa pst) semInput+ -- realisations tab+ (results,_,summTab,resTab) <- BG.resultsPnl builderGui pstRef nb semInput+ -- ranking tab+ mRankTab <- if hasFlagP RankingConstraintsFlg (pa pst)+ then Just <$> messageGui nb (purty pst results)+ else return Nothing+ -- tabs+ let myTabs = catMaybes+ [ Just (tab "summary" summTab)+ , Just (tab "realisations" resTab)+ , tab "ranking" <$> mRankTab+ , Just (tab "input" inputTab)+ ]+ -- pack it all together+ set f [ layout := container p $ column 0 [ tabs nb myTabs ]+ , clientSize := bigSize ]+ repaint f+ return ()+ where+ purty pst res = T.unlines $ map (prettyResult pst) [ x | GSuccess x <- res ]+++-- --------------------------------------------------------------------+-- Debugging+-- --------------------------------------------------------------------++-- | Information about the config/input in this session+inputInfoGui :: Window a -- ^ parent window+ -> Params+ -> SemInput+ -> IO Layout+inputInfoGui f config semInput = messageGui f . T.unlines $+ [ geniShowText semInput+ , ""+ , "Options"+ , "-------"+ , "Root feature: " <> maybe "" pretty (getFlagP RootFeatureFlg config)+ , ""+ , "Optimisations"+ , "-------------"+ ] ++ map optStatus optBios ++ polStuff++ where+ 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)+ polStuff = if enabld polarisedBio+ then [ ""+ , "Detect polarities: " <> T.pack dps+ ]+ else []++-- | We provide here a universal debugging interface, which makes use of some+-- parameterisable bits as defined in the BuilderGui module.+debugGui :: BG.BuilderGui -> 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"+ , fullRepaintOnResize := False+ , clientSize := sz 300 300+ ]+ p <- panel f []+ nb <- notebook p []+ let addTabs [] = return ()+ addTabs ts = do+ oldCount <- notebookGetPageCount nb+ set f [ layout := container p (tabs nb ts) -- appends ts+ , clientSize := bigSize+ ]+ notebookSetSelection nb oldCount >> return ()+ -- generation step 1+ (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)+ where+ myPolarityGui nb autstuff =+ fst3 <$> polarityGui nb (prIntermediate autstuff) (prFinal autstuff)+ noBv x = (x, -1) -- all true?++-- ----------------------------------------------------------------------+-- odds and ends+-- ----------------------------------------------------------------------++bigSize :: Size2D Int+bigSize = sz 700 600++modifyParams :: (Params -> Params) -> ProgState -> ProgState+modifyParams f pst = pst { pa = f (pa pst) }++-- vim: set sw=4:
+ src/NLP/GenI/GuiHelper.hs view
@@ -0,0 +1,810 @@+-- GenI surface realiser+-- Copyright (C) 2005 Carlos Areces and Eric Kow+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License+-- as published by the Free Software Foundation; either version 2+-- of the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+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 Graphics.UI.WX++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++-- ----------------------------------------------------------------------+-- Types+-- ----------------------------------------------------------------------++data GraphvizStatus = GvError String+ | GvNoSuchItem Int+ | GvCached+ | GvCreated FilePath+ deriving Show++-- ----------------------------------------------------------------------+-- Lexically selected items+-- ----------------------------------------------------------------------++-- | 'pauseOnLexGui' allows the user to see lexical selection only and either+-- dump it to file or read replace it by the contents of some other file+pauseOnLexGui :: Params+ -> Window a -- ^ parent window+ -> [LexEntry] -- ^ lexically selected items (before anchoring)+ -> [TagElem] -- ^ lexically selected items+ -> GeniWarnings -- ^ lexical selection warnings+ -> Maybe ([TagElem] -> IO ()) -- ^ run when “begin” is clicked+ -> GvIO () (GvItem Bool TagElem)+pauseOnLexGui config f lexs xs warns mjob = do+ p <- panel f []+ candV <- varCreate xs+ (tb, ref, updater) <- candidateGui config p xs warns+ -- supplementary button bar+ let dispCmd = T.putStrLn (geniShowText lexs)+ saveCmd = do+ cs <- varGet candV+ maybeSaveAsFile f (geniShowText cs <> "\n")+ loadCmd = loadLex $ \cs -> do+ varSet candV cs+ setGvDrawables ref (sectionsBySem cs)+ updater+ --+ dispBt <- button p [ text := "Show lexical entries", on command := dispCmd ]+ saveBt <- button p [ text := "Save selection", on command := saveCmd ]+ loadBt <- button p [ text := "Load", on command := loadCmd ]+ nextBt <- button p [ text := "Begin" ]+ let disableBar = forM_ [ loadBt, nextBt ] $+ \w -> set w [ enabled := False ]+ continue job = do+ disableBar+ varGet candV >>= job+ case mjob of+ Nothing -> disableBar+ Just j -> set nextBt [ on command := continue j ]+ let lay = fill $ container p $ column 5+ [ fill tb, hfill (vrule 1)+ , row 0 [ row 5 [ widget dispBt, widget saveBt, widget loadBt ]+ , hfloatRight $ widget nextBt ] ]+ return (lay, ref, updater)+ where+ loadLex job = do+ fsel <- fileOpenDialog f False True+ "Choose your file..."+ anyFile "" ""+ flip maybeIO fsel $ \file -> do+ parsed <- parseFromFile geniTagElems file+ case parsed of+ Left err -> errorDialog f "" (show err)+ Right c -> job c+++-- | 'candidateGui' displays the lexically selected items, grouped by the+-- semantics they subsume.+candidateGui :: Params+ -> Window a+ -> [TagElem]+ -> GeniWarnings+ -> GvIO () (GvItem Bool TagElem)+candidateGui config f xs warns = do+ pouter <- panel f []+ split <- splitterWindow pouter []+ p <- panel split []+ (tb,gvRef,updater) <- tagViewerGui config p "lexically selected item" "candidates"+ $ sectionsBySem xs+ let polFeats = "Polarity attributes detected:" <+>+ case suggestPolFeatures xs of+ [] -> "None! :-("+ fs -> T.unwords fs+ addPolFeats fs = if hasOpt Polarised config then polFeats : fs else fs+ lexWarnings = concatMap showGeniWarning . fromGeniWarnings . sortWarnings $ warns+ warning = T.unlines $ filter (not . T.null) (addPolFeats lexWarnings)+ -- side panel+ sidePnl <- panel p []+ ifaceLst <- singleListBox sidePnl [ tooltip := "interface for this tree (double-click me!)" ]+ traceLst <- singleListBox sidePnl [ tooltip := "trace for this tree (double-click me!)" ]+ tNoted <- textCtrl sidePnl [ wrap := WrapWord, text := "Hint: copy from below and paste into the sem:\n" ]+ let laySide = container sidePnl $ column 2+ [ label "interface"+ , fill $ widget ifaceLst+ , label "trace"+ , fill $ widget traceLst+ , label "notes"+ , fill $ widget tNoted ]+ -- handlers+ let addLine :: String -> String -> String+ addLine x y = y ++ "\n" ++ x+ --+ addToNoted w =+ do sel <- get w selection+ things <- get w items+ when (sel > 0) $ set tNoted [ text :~ addLine (things !! sel) ]+ set ifaceLst [ on doubleClick := \_ -> addToNoted ifaceLst ]+ set traceLst [ on doubleClick := \_ -> addToNoted traceLst ]+ -- updaters : what happens when the user selects an item+ let updateTrace = gvOnSelect (return ())+ (\s -> set traceLst [ items := map T.unpack $ ttrace s ])+ updateIface = gvOnSelect (return ())+ (\s -> set ifaceLst [ items := map prettyStr $ tinterface s ])+ Monad.unless (null xs) $ do+ addGvHandler gvRef updateTrace+ addGvHandler gvRef updateIface+ -- first time run+ gvSt <- readIORef gvRef+ updateIface gvSt+ updateTrace gvSt+ --+ let layMain = fill $ row 2 [ fill tb, vfill laySide ]+ warningTxt <- textCtrl split [ text := T.unpack warning ]+ let lay = fill . container pouter+ $ fill $ hsplit split 5 100 (widget warningTxt) (container p layMain)+ return (lay, gvRef, updater)++sectionsBySem :: (TagItem t) => [t] -> [GvItem Bool t]+sectionsBySem tsem =+ concatMap section sem+ where+ semmap = mapBySem tsem+ sem = Map.keys semmap+ --+ lookupTr k = Map.findWithDefault [] k semmap+ section k = GvHeader header : map tlab (lookupTr k)+ where+ header = "___" <> pretty k <> "___"+ tlab t = GvItem (tgIdName t) False t++-- ----------------------------------------------------------------------+-- Polarity Automata+-- ----------------------------------------------------------------------++-- | A browser to see the automata constructed during the polarity optimisation+-- step.+polarityGui :: Window a -- ^ parent window+ -> [AutDebug] -- ^ intermediary automata+ -> PolAut -- ^ final automaton+ -> GvIO () (GvItem () PolAut)+polarityGui f xs final = do+ gvRef <- newGvRef () "automata"+ setGvDrawables gvRef $ concatMap toItem xs ++ [finalItem]+ graphvizGui f "polarity" gvRef+ 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"++-- ----------------------------------------------------------------------+-- Helpers+-- ----------------------------------------------------------------------++-- | Any data structure which has corresponds to a TAG tree and which+-- has some notion of derivation+class XMGDerivation a where+ getSourceTrees :: a -> [Text]++instance XMGDerivation TagElem where+ getSourceTrees te = [idname te]++-- | 'toSentence' almost displays a 'TagElem' as a sentence, but only good+-- enough for debugging needs. The problem is that each leaf may be+-- an atomic disjunction. Our solution is just to display each choice and+-- use some delimiter to seperate them. We also do not do any+-- morphological processing.+toSentence :: TagElem -> Text+toSentence = T.unwords . map squishLeaf . tagLeaves++squishLeaf :: (a,([Text], b)) -> Text+squishLeaf = showLexeme . fst . snd++-- ----------------------------------------------------------------------+-- TAG viewer+-- ----------------------------------------------------------------------++-- | Variant of 'graphvizGui' with a toggle to view feature structures+tagViewerGui :: (GraphvizShow (GvItem Bool t), XMGDerivation t)+ => Params+ -> Window a -- ^ parent+ -> Text -- ^ tooltip+ -> FilePath -- ^ cache directory for graphviz+ -> [GvItem Bool t] -- ^ items+ -> GvIO () (GvItem Bool t)+tagViewerGui config f tip cachedir itNlab = do+ p <- panel f []+ gvRef <- newGvRef () tip+ setGvDrawables gvRef itNlab+ (lay,ref,onUpdate) <- graphvizGui p cachedir gvRef+ -- button bar widgets+ detailsChk <- checkBox p [ text := "Show features"+ , checked := False ]+ viewTagLay <- viewTagWidgets p gvRef config+ -- handlers+ let onDetailsChk = do+ isDetailed <- get detailsChk checked+ modifyGvItems gvRef (gvItemSetFlag isDetailed)+ onUpdate+ set detailsChk [ on command := onDetailsChk ]+ -- pack it all in+ let cmdBar = hfill $ row 5 [ dynamic $ widget detailsChk, viewTagLay ]+ lay2 = fill $ container p $ column 5 [ fill lay, cmdBar ]+ return (lay2,ref,onUpdate)++-- ----------------------------------------------------------------------+-- XMG Metagrammar stuff.+-- See <http://sourcesup.cru.fr/xmg/>+-- ----------------------------------------------------------------------++-- | Calls Yannick Parmentier's handy visualisation tool ViewTAG.+viewTagWidgets :: (GraphvizShow (GvItem Bool t), XMGDerivation t)+ => Window a -- ^ parent window+ -> GraphvizGuiRef st (GvItem Bool t)+ -> Params+ -> IO Layout+viewTagWidgets p gvRef config = do+ viewTagBtn <- button p [ text := "ViewTAG" ]+ viewTagCom <- choice p [ tooltip := "derivation tree" ]+ -- handlers+ let onViewTag d = readIORef gvRef >>=+ gvOnSelect (return ()) (const (runViewTag config (T.unpack d)))+ -- when the user selects a tree, we want to update the list of derivations+ let updateDerivationList = gvOnSelect+ (set viewTagCom [ enabled := False ])+ (\s -> do+ let dervs = getSourceTrees s+ set viewTagCom [ enabled := True+ , items := map T.unpack dervs+ ]+ setSelection viewTagCom dervs 0 $ \d ->+ set viewTagBtn [ on command := onViewTag d ]+ )+ addGvHandler gvRef updateDerivationList+ updateDerivationList =<< readIORef gvRef+ --+ return $ row 5 $ map dynamic [ widget viewTagCom, widget viewTagBtn ]++runViewTag :: Params -> String -> IO ()+runViewTag params drName =+ maybeOrWarn warnTf (getFlagP MacrosFlg params) $ \f ->+ maybeOrWarn warnVc (getFlagP ViewCmdFlg params) $ \cmd ->+ actuallyView f cmd+ where+ warnTf = "Warning: No tree schema file specified (runViewTag)"+ warnVc = "Warning: No viewcmd specified (runViewTag)"+ treenameOnly = takeWhile (/= ':')+ . dropTillIncluding ':' . dropTillIncluding ':'+ -- run the viewer+ actuallyView f cmd =+ runProcess cmd [ dropExtensions f <.> "rec", treenameOnly drName]+ Nothing Nothing Nothing Nothing Nothing >> return ()++-- --------------------------------------------------------------------+-- Graphical debugger (helper functions)+-- --------------------------------------------------------------------+++type DebuggerItemBar st flg itm =+ Panel () -- ^ parent panel+ -> GraphvizGuiRef st (GvItem flg itm) -- ^ gv ref to use+ -> GvUpdater -- ^ onUpdate+ -> IO (Layout, GvUpdater)++data GraphvizShow (GvItem flg itm) => Debugger st flg itm = Debugger+ { dBuilder :: B.Builder st itm Params+ -- ^ builder to use+ , 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+ -- ^ graphviz cache directory+ , dNext :: [GeniResult] -> Statistics -> IO ()+ }++-- | A generic graphical debugger widget for GenI, including+--+-- * item viewer which allows the user to select one of the items in the+-- builder state.+--+-- * item bar which provides some options on how to view the currently+-- selected item, for example, if you want to display the features or not.+--+-- * A dashboard which lets the user do things like ``go ahead 6 steps''.+--+-- Besides the Builder, there are two functions you need to pass in make this+-- work:+--+-- 1. a 'stateToGv' which converts the builder state into a list of items+-- and labels the way 'graphvizGui' likes it+--+-- 2. an 'item bar' function which lets you control what bits you display+-- of a selected item (for example, if you want a detailed view or not)+-- the item bar should return a layout+--+-- Note that we don't constrain the type of item returned by the builder to+-- be the same as the type handled by your gui: that's quite normal because+-- you might want to decorate the type with some other information+debuggerPanel :: GraphvizShow (GvItem flg itm)+ => Debugger st flg itm+ -> ProgStateRef+ -> Window a -- ^ parent window+ -> B.Input+ -> IO Layout+debuggerPanel (Debugger {..}) pstRef f input = do+ config <- (setMetrics . pa) <$> readIORef pstRef+ let (initS, initStats) = initBuilder input config+ p <- panel f []+ -- ---------------------------------------------------------+ -- item viewer: select and display an item+ -- ---------------------------------------------------------+ gvRef <- newGvRef initS "debugger session"+ setGvDrawables gvRef (dToGv initS)+ (layItemViewer,_,onUpdateMain) <- graphvizGui p dCacheDir gvRef+ -- ----------------------------------------------------------+ -- item bar: controls for how an individual item is displayed+ -- ----------------------------------------------------------+ (layItemBar,onUpdateItemBar) <- dControlPnl p gvRef onUpdateMain+ -- -------------------------------------------+ -- dashboard: controls for the debugger itself+ -- -------------------------------------------+ let onUpdate = onUpdateMain >> onUpdateItemBar+ db <- panel p []+ restartBt <- button db [text := "Start over"]+ nextBt <- button db [text := "Step by..."]+ leapVal <- entry db [ text := "1", clientSize := sz 30 25 ]+ finishBt <- button db [text := "Leap to end"]+ statsTxt <- staticText db []+ done <- varCreate False+ -- dashboard commands+ let showQuery c gs = maybe "???" show (queryCounter c gs)+ updateStatsTxt gs = set statsTxt [ text :~ (\_ -> txtStats gs) ]+ txtStats gs = unwords [ "itr", showQuery num_iterations gs+ , "chart sz", showQuery chart_size gs+ ]+ ++ "\ncomparisons: " ++ showQuery num_comparisons gs+ let genStep _ (st,stats) = runState (execStateT nextStep st) stats+ let showNext s_stats = do+ leapTxt <- get leapVal text+ let leapInt :: Integer+ leapInt = read leapTxt+ (s2,stats2) = foldr genStep s_stats [1..leapInt]+ modifyIORef gvRef $ \g -> g { gvcore = s2 }+ setGvDrawables gvRef (dToGv s2)+ setGvSel gvRef 1+ onUpdate+ updateStatsTxt stats2+ set nextBt [ on command :~ (\_ -> showNext (s2,stats2) ) ]+ case B.finished dBuilder s2 of+ B.Active -> return ()+ _ -> callNext done stats2 s2+ let showLast = do+ -- redo generation from scratch+ let (s2, stats2) = runState (execStateT allSteps initS) initStats+ setGvDrawables gvRef (dToGv s2)+ onUpdate+ updateStatsTxt stats2+ callNext done stats2 s2+ let showReset = do+ set nextBt [ on command := showNext (initS, initStats) ]+ updateStatsTxt initStats+ setGvDrawables gvRef (dToGv initS)+ setGvSel gvRef 1+ onUpdate+ -- dashboard handlers+ set finishBt [ on command := showLast ]+ set restartBt [ on command := showReset ]+ showReset+ -- dashboard layout+ let layCmdBar = hfill $ container db $ row 5+ [ widget statsTxt, hfloatRight $ row 5+ [ widget restartBt, widget nextBt+ , widget leapVal, label " step(s)"+ , widget finishBt ] ]+ -- -------------------------------------------+ -- overall layout+ -- -------------------------------------------+ return $ fill $ container p $ column 5 [ layItemViewer, layItemBar, hfill (vrule 1), layCmdBar ]+ where+ initBuilder = B.init dBuilder+ nextStep = B.step dBuilder+ allSteps = B.stepAll dBuilder+ setMetrics = setFlagP 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+ dNext results stats++-- --------------------------------------------------------------------+-- Graphviz GUI+-- --------------------------------------------------------------------+++data GraphvizOrder = GvoParams | GvoItems | GvoSel+ deriving Eq++data GraphvizGuiSt st a = GvSt+ { gvcore :: st+ , gvitems :: Map.Map Int a+ , gvlabels :: [Text]+ , gvtip :: Text -- ^ tooltip for the selection box+ -- | handler function to call when the selection is+ -- updated (note: before displaying the object)+ , gvhandler :: Maybe (GraphvizGuiSt st a -> IO ())+ , gvsel :: Int+ , gvorders :: [GraphvizOrder]+ }++-- | This provides a mechanism for communicating with the GUI. The basic idea:+--+-- 1. you create a GvRef with newGvRef+--+-- 2. you call 'graphvizGui' and get back an updater function+--+-- 3. whenever you want to modify something, you use setGvWhatever and call+-- the updater function+--+-- 4. if you want to react to the selection being changed, you should set+-- gvhandler+type GraphvizGuiRef st a = IORef (GraphvizGuiSt st a)++newGvRef :: st -> Text -> IO (GraphvizGuiRef st a)+newGvRef initSt t = newIORef GvSt+ { gvcore = initSt+ , gvitems = Map.empty+ , gvlabels = []+ , gvhandler = Nothing+ , gvtip = t+ , gvsel = 0+ , gvorders = []+ }++setGvSel :: GraphvizGuiRef st a -> Int -> IO ()+setGvSel gvref s = modifyIORef gvref $ \x ->+ x { gvsel = s, gvorders = GvoSel : gvorders x }++modifyGvItems :: GraphvizGuiRef st a -> (a -> a) -> IO ()+modifyGvItems gvref fn =+ modifyIORef gvref $ \s -> s { gvitems = Map.map fn (gvitems s) }++setGvDrawables :: GraphvizGuiRef st (GvItem f a) -> [GvItem f a] -> IO ()+setGvDrawables gvref itlb = modifyIORef gvref $ \x ->+ x { gvitems = Map.fromList $ zip [0..] itlb+ , gvlabels = map gvItemLabel itlb+ , gvorders = GvoItems : gvorders x+ }++-- | Helper function for making selection handlers (see 'addGvHandler')+-- Note that this was designed for cases where the contents is a Maybe+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+ where+ sel = gvsel gvSt+ things = gvitems gvSt++setGvHandler :: GraphvizGuiRef st a -> Maybe (GraphvizGuiSt st a -> IO ()) -> IO ()+setGvHandler gvref mh = do+ gvSt <- readIORef gvref+ modifyIORef gvref (\x -> x { gvhandler = mh })+ maybeIO ($ gvSt) mh++-- | add a selection handler - if there already is a handler+-- this handler will be called before the new one+addGvHandler :: GraphvizGuiRef st a -> (GraphvizGuiSt st a -> IO ()) -> IO ()+addGvHandler gvref h = do+ gvSt <- readIORef gvref+ let newH = case gvhandler gvSt of+ Nothing -> h+ Just oldH -> \g -> oldH g >> h g+ setGvHandler gvref (Just newH)++type GvIO st d = IO (Layout, GraphvizGuiRef st d, GvUpdater)+type GvUpdater = IO ()++-- |'graphvizGui' @f glab cachedir gvRef@ is a general-purpose GUI for+-- displaying a list of items graphically via AT&T's excellent Graphviz+-- utility. We have a list box where we display all the labels the user+-- provided. If the user selects an entry from this box, then the item+-- corresponding to that label will be displayed.+--+-- This returns a layout (wxhaskell container) and a function that you're+-- expected to call whever something changes that would require the GUI to+-- refresh itself (for example, you create a new chart item)+--+-- * @f@ - (parent window) the GUI is provided as a panel within the parent.+-- Note: we use window in the WxWidget's sense, meaning it could be+-- anything as simple as a another panel, or a notebook tab.+-- * @glab@ - (gui labels) a tuple of strings (tooltip, next button text)+-- * @cachedir@ - the cache subdirectory. We intialise this by creating a cache+-- directory for images which will be generated from the results+-- * @gvRef@ - see above+graphvizGui :: GraphvizShow d => Window a -> String -> GraphvizGuiRef st d -> GvIO st d+graphvizGui f cachedir gvRef = do+ initGvSt <- readIORef gvRef+ -- widgets+ p <- panel f [ fullRepaintOnResize := False ]+ split <- splitterWindow p []+ (dtBitmap,sw) <- scrolledBitmap split+ rchoice <- singleListBox split [ tooltip := T.unpack (gvtip initGvSt) ]+ -- set handlers+ let openFn = openImage sw dtBitmap+ -- pack it all together+ let lay = fill $ container p $ margin 1 $ fill $+ vsplit split 5 200 (widget rchoice) (widget sw)+ set p [ on closing := closeImage dtBitmap ]+ ------------------------------------------------+ -- create an updater function+ ------------------------------------------------+ let withoutSelector job =+ bracket ( swap rchoice (on select) (return ()) )+ ( \fn -> set rchoice [ on select := fn ] )+ ( const job )+ -- the selector calls onUpdate which calls the selector+ -- indirectly by setting the selection+ let onUpdate = withoutSelector $ do+ gvSt <- readIORef gvRef+ let orders = gvorders gvSt+ initCacheDir cachedir+ Monad.when (GvoItems `elem` orders) $+ set rchoice [ items := map T.unpack (gvlabels gvSt) ]+ Monad.when (GvoSel `elem` orders) $+ set rchoice [ selection := gvsel gvSt ]+ modifyIORef gvRef (\x -> x { gvorders = []})+ createAndOpenImage cachedir p gvRef openFn+ ------------------------------------------------+ -- enable the tree selector+ -- FIXME: not sure that this is correct+ ------------------------------------------------+ let selectAndShow = do+ -- putStrLn "selectAndShow called"+ sel <- get rchoice selection+ -- note: do not use setGvSel (infinite loop)+ modifyIORef gvRef (\x -> x { gvsel = sel })+ -- call the handler if there is one+ gvSt <- readIORef gvRef+ maybeIO ($ gvSt) (gvhandler gvSt)+ -- now do the update+ onUpdate+ ------------------------------------------------+ set rchoice [ on select := selectAndShow ]+ -- call the updater function for the first time+ setGvSel gvRef 1+ onUpdate+ -- return the layout, the gvRef, and an updater function+ -- The gvRef is to make it easier for users to muck around with the+ -- state of the gui. Here, it's trivial, but when people combine guis+ -- together, it might be easier to keep track of when returned+ return (lay, gvRef, onUpdate)++-- ----------------------------------------------------------------------+-- Bitmap stuff+-- ----------------------------------------------------------------------++-- | Bitmap with a scrollbar+scrolledBitmap :: Window a -> IO(VarBitmap, ScrolledWindow ())+scrolledBitmap p = do+ dtBitmap <- variable [value := Nothing]+ sw <- scrolledWindow p [ scrollRate := sz 10 10+ , bgcolor := white+ , on paint := onPaint dtBitmap+ , fullRepaintOnResize := False+ ]+ return (dtBitmap, sw)++type OpenImageFn = FilePath -> IO ()+type VarBitmap = Var (Maybe (Bitmap ()))++openImage :: Window a -> VarBitmap -> OpenImageFn+openImage sw vbitmap fname = do+ -- load the new bitmap+ bm <- bitmapCreateFromFile fname -- can fail with exception+ closeImage vbitmap+ set vbitmap [value := Just bm]+ -- reset the scrollbars+ bmsize <- get bm size+ set sw [virtualSize := bmsize]+ repaint sw++closeImage :: VarBitmap -> IO ()+closeImage vbitmap =+ maybeIO objectDelete =<< swap vbitmap value Nothing++onPaint :: VarBitmap -> DC a -> b -> IO ()+onPaint vbitmap dc _ =+ maybeIO draw =<< get vbitmap value+ where+ draw bm = dcClear dc >> drawBitmap dc bm pointZero False []++-- | 'createAndOpenImage' attempts to draw an image (or retrieve it from cache)+-- and opens it if we succeed. Otherwise, it does nothing at all; the creation+-- function will display an error message if it fails.+createAndOpenImage :: GraphvizShow b+ => FilePath -- ^ cache directory+ -> Window a -- ^ parent window+ -> GraphvizGuiRef st b+ -> OpenImageFn+ -> IO ()+createAndOpenImage cachedir f gvref openFn = do+ gvStatus <- createImage cachedir f gvref+ case gvStatus of+ GvCreated g -> openGraphic g+ GvNoSuchItem _ -> return ()+ GvError err -> errorDialog f "" err+ GvCached -> return ()+ where+ openGraphic graphic = do+ exists <- doesFileExist graphic+ if exists+ then openFn graphic+ else errorDialog f "" (noFile graphic)+ noFile g = "The file " ++ g ++ " was not created! Is graphviz installed?"++-- | Creates a graphical visualisation for anything which can be displayed+-- by graphviz.+createImage :: GraphvizShow b+ => FilePath -- ^ cache directory+ -> Window a -- ^ parent window+ -> GraphvizGuiRef st b -- ^ stuff to display+ -> IO GraphvizStatus+createImage cachedir f gvref = do+ gvSt <- readIORef gvref+ -- putStrLn $ "creating image via graphviz"+ let drawables = gvitems gvSt+ sel = gvsel gvSt+ dotFile <- createDotPath cachedir (show sel)+ graphicFile <- createImagePath cachedir (show sel)+ let create x = do _ <- toGraphviz x dotFile graphicFile+ return . GvCreated $ graphicFile+ handler :: GraphvizException -> IO GraphvizStatus+ handler err = do+ errorDialog f "Error calling graphviz. Is it installed?" (show err)+ return . GvError . show $ err+ 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++-- | 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.+initCacheDir :: String -> IO()+initCacheDir cachesubdir = do+ mainCacheDir <- gvCACHEDIR+ cmainExists <- doesDirectoryExist mainCacheDir+ unless cmainExists $ createDirectory mainCacheDir+ let cachedir = mainCacheDir </> cachesubdir+ cExists <- doesDirectoryExist cachedir+ if cExists+ then do+ contents <- filter notJunk <$> getDirectoryContents cachedir+ mapM_ (removeFile . (cachedir </>)) contents+ else createDirectory cachedir+ where+ notJunk = (`notElem` [".", ".."])++-- ----------------------------------------------------------------------+-- Miscellaneous+-- ----------------------------------------------------------------------++-- | Set a selection widget's selection reactor+-- We assume you've already populated it (radio boxes cannot be added to,+-- so we have to let you do it manually on initialisation)+setSelection :: (Selecting w, Selection w, Items w String)+ => w -- ^ widget+ -> [a] -- ^ items+ -> Int -- ^ initial selection+ -> (a -> IO ()) -- ^ on selection+ -> IO ()+setSelection widgt xs initial reactor = do+ set widgt [ selection := initial+ , on select := onSelection ]+ onSelection+ where+ imap = listArray (0, length xs - 1) xs+ onSelection = do+ sel <- get widgt selection+ reactor (imap ! sel)++-- | Save the given string to a file, if the user selets one via the file save+-- dialog. Otherwise, don't do anything.+maybeSaveAsFile :: Window a -> Text -> IO ()+maybeSaveAsFile f msg = do+ fsel <- fileSaveDialog f False True "Save to" anyFile "" ""+ case fsel of+ 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 ]+ return $ fill $ container p $ column 1 [ fill (widget t) ]++gvCACHEDIR :: IO String+gvCACHEDIR = do+ home <- getHomeDirectory+ return (home </> ".gvcache")++createImagePath :: String -> String -> IO String+createImagePath subdir name = do+ cdir <- gvCACHEDIR+ return (cdir </> subdir </> name <.> "png")++createDotPath :: String -> String -> IO String+createDotPath subdir name = do+ cdir <- gvCACHEDIR+ return (cdir </> subdir </> name <.> "dot")++maybeOrWarn :: String -- ^ warning+ -> Maybe a+ -> (a -> IO ())+ -> IO ()+maybeOrWarn warning m job = maybe (ePutStrLn warning) job m++maybeIO :: (a -> IO ()) -> Maybe a -> IO ()+maybeIO = maybe (return ())++anyFile :: [ (String,[String]) ]+anyFile = [("Any file",["*","*.*"])]
+ src/NLP/GenI/MainGui.hs view
@@ -0,0 +1,57 @@+-- GenI surface realiser+-- Copyright (C) 2005 Carlos Areces and Eric Kow+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License+-- as published by the Free Software Foundation; either version 2+-- of the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++{-# LANGUAGE CPP #-}+module NLP.GenI.MainGui where++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)++main :: IO ()+main = getArgs+ >>= treatArgs optionsForStandardGenI+ >>= processInstructions+ >>= (mainWithState . emptyProgState)++mainWithState :: ProgState -> IO ()+mainWithState pst = do+ pname <- getProgName+ maybe (return ()) setLoggers =<< readGlobalConfig+ pstRef <- newIORef pst+ let has :: (Typeable f, Typeable x) => (x -> f) -> Bool+ has = flip hasFlagP (pa 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
+ src/NLP/GenI/Simple/SimpleGui.hs view
@@ -0,0 +1,293 @@+-- GenI surface realiser+-- Copyright (C) 2005 Carlos Areces and Eric Kow+--+-- This program is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License+-- as published by the Free Software Foundation; either version 2+-- of the License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software+-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module NLP.GenI.Simple.SimpleGui where++import Control.Applicative ( (<$>) )+import Control.Arrow ( (***) )+import 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 qualified Data.GraphViz as GV+import qualified Data.GraphViz.Attributes.Complete as GV+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++-- --------------------------------------------------------------------+-- Interface+-- --------------------------------------------------------------------++simpleGui2p, simpleGui1p :: BG.BuilderGui+simpleGui2p = simpleGui True+simpleGui1p = simpleGui False++simpleGui :: Bool -> BG.BuilderGui+simpleGui twophase = BG.BuilderGui+ { BG.resultsPnl = resultsPnl twophase+ , BG.summaryPnl = summaryGui+ , BG.debuggerPnl = simpleDebuggerTab twophase+ }++resultsPnl :: Bool -> 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)++-- --------------------------------------------------------------------+-- Results+-- --------------------------------------------------------------------++-- Derived Trees++-- | Browser for derived/derivation trees, except if there are no results, we show a+-- message box+realisationsGui :: ProgStateRef -> 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+ tagViewerGui config f tip "derived" itNlabl+ where+ tip = "result"+ mkItNLabl x = GvItem (siToSentence x) False x+ itNlabl = map mkItNLabl resultsRaw++summaryGui :: ProgStateRef+ -> Window a+ -> [GeniResult]+ -> Statistics -> IO Layout+summaryGui _ f results stats = do+ p <- panel f []+ statsTxt <- textCtrl p [ text := showFinalStats stats ]+ t <- textCtrl p [ text := T.unpack msg ]+ saveBt <- button p [ text := "Save to file"+ , on command := maybeSaveAsFile f msg ]+ return $ fill $ container p $ column 1+ [ hfill $ label "Performance data"+ , hfill $ widget statsTxt+ , hfill $ label $ "Realisations (" ++ show totalResults ++ " found)"+ , fill $ widget t+ , hfloatRight $ widget saveBt+ ]+ where+ (succeses, errors) = partitionGeniResult results+ taggedResults = concatMap sentences succeses+ resultBuckets = buckets snd taggedResults+ sentences gr = map (\r -> (grOrigin gr, r)) (grRealisations gr)+ prettyBucket (s, xys) = s <+> parens instances+ where+ instances = if length ys == 1+ then ys_str+ else pretty (length ys) <+> "instances:" <+> ys_str+ ys = map fst xys+ ys_str = T.intercalate ", " . map pretty . sort $ ys+ msg = T.unlines $ concatMap fromError errors+ ++ (if null succeses+ then [ "(none)" ]+ else map prettyBucket resultBuckets)+ totalResults = length taggedResults+ fromError (GeniError e) = e++partitionGeniResult :: [GeniResult] -> ([GeniSuccess],[GeniError])+partitionGeniResult results = (map unSucc *** map unErr)+ $ partition isSuccess results+ where+ unSucc (GSuccess x) = x+ unSucc _ = error "NLP.GenI.Simple.SimpleGui unSucc"+ unErr (GError x) = x+ unErr _ = error "NLP.GenI.Simple.SimpleGui unErr"++-- --------------------------------------------------------------------+-- Debugger+-- --------------------------------------------------------------------++simpleDebuggerTab :: Bool+ -> ProgStateRef+ -> 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+ where+ dbg :: Params -> Debugger SimpleStatus Bool SimpleItem+ dbg config = Debugger+ { dBuilder = simpleBuilder twophase+ , dToGv = stToGraphviz+ , dControlPnl = simpleItemBar config+ , dNext = job+ , dCacheDir = name+ }++stToGraphviz :: SimpleStatus -> [GvItem Bool SimpleItem]+stToGraphviz st =+ concat [ agenda, auxAgenda, chart, trash, results ]+ where+ agenda = section "AGENDA" $ theAgenda st+ auxAgenda = section "HOLDING" $ theHoldingPen st+ trash = section "TRASH" $ theTrash st+ chart = section "CHART" $ theChart st+ results = section "RESULTS" $ theResults st+ --+ section n i = hd : map tlFn i+ where+ hd = GvHeader ("___" <> n <> "___")+ tlFn x = GvItem (siToSentence x <+> prettyPaths x) False x+ prettyPaths = parens . prettyPolPaths . siPolpaths++simpleItemBar :: Params -> DebuggerItemBar SimpleStatus Bool SimpleItem+simpleItemBar config f gvRef updaterFn = do+ ib <- panel f []+ phaseTxt <- staticText ib [ text := "" ]+ detailsChk <- checkBox ib [ text := "Show features"+ , checked := False ]+ viewTagLay <- viewTagWidgets ib gvRef config+ -- handlers+ let onDetailsChk = do+ isDetailed <- get detailsChk checked+ modifyGvItems gvRef (gvItemSetFlag isDetailed)+ updaterFn+ set detailsChk [ on command := onDetailsChk ]+ --+ let lay = hfloatCentre . container ib . row 5 $+ [ hspace 5+ , widget phaseTxt+ , hglue+ , widget detailsChk+ , hglue+ , viewTagLay+ , hspace 5 ]+ let onUpdate = do+ status <- gvcore `fmap` readIORef gvRef+ set phaseTxt [ text := show (step status) ]+ return (lay, onUpdate)++-- --------------------------------------------------------------------+-- Miscellaneous+-- -------------------------------------------------------------------++-- to have the basic GraphvizShow functionality+newtype SimpleItemWrapper = SimpleItemWrapper { fromSimpleItemWrapper :: SimpleItem }++instance TagItem SimpleItemWrapper where+ tgIdName = siIdname . siGuiStuff . fromSimpleItemWrapper+ tgIdNum = siId . fromSimpleItemWrapper+ tgSemantics = siFullSem . siGuiStuff . fromSimpleItemWrapper+ tgTree si =+ lookupOrBug <$> siDerived (fromSimpleItemWrapper si)+ where+ lookupOrBug k = fromMaybe (buggyNode k) $ Map.lookup k nodeMap+ nodeMap = fromListUsingKey gnname (siNodes (fromSimpleItemWrapper si))+ buggyNode k = GN+ { gup = [ AvPair "cat"+ (mkGConstNone $ "ERROR looking up" <+> k)+ ]+ , gdown = []+ , gnname = "ERROR"+ , glexeme = []+ , gtype = Other+ , ganchor = False+ , gaconstr = False+ , gorigin = "ERROR"+ }++fromListUsingKey :: Ord k => (a -> k) -> [a] -> Map.Map k a+fromListUsingKey f xs = Map.fromList [ (f x, x) | x <- xs ]++instance XMGDerivation SimpleItem where+ -- Note: this is XMG-related stuff+ getSourceTrees it = map dsChild (siDerivation it)++instance GraphvizShow (GvItem Bool SimpleItem) where+ graphvizLabel (GvHeader _) = ""+ graphvizLabel g@(GvItem _ _ c) =+ gvUnlines $ graphvizLabel (highlightSimpleItem g)+ : map TL.pack (siDiagnostic (siGuiStuff c))++ graphvizParams = graphvizParams . highlightSimpleItem++ graphvizShowAsSubgraph _ (GvHeader _) = []+ graphvizShowAsSubgraph p g@(GvItem _ _ it) =+ graphvizShowAsSubgraph (p `TL.append` "TagElem") (highlightSimpleItem g)+ ++ graphvizShowDerivation (siDerivation it)++highlightSimpleItem :: GvItem Bool SimpleItem -> GvItem GNodeHighlights SimpleItemWrapper+highlightSimpleItem (GvHeader h) = GvHeader h+highlightSimpleItem (GvItem l f it) = GvItem l (f, highlights) (SimpleItemWrapper it)+ where+ highlights :: Highlights (GNode GeniVal)+ highlights n =+ if gnname n `elem` siHighlight (siGuiStuff it)+ then Just (GV.X11Color GV.Red)+ else Nothing++siToSentence :: SimpleItem -> T.Text +siToSentence si =+ case unpackResult si of+ [] -> siIdname . siGuiStuff $ si+ (h:_) -> T.unwords ((idstr <> ".") : map lpLemma (snd3 h))+ where+ idstr = pretty (siId si)