uni-htk 2.2.0.0 → 2.2.1.0

raw patch · 14 files changed

+105/−75 lines, 14 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• HTk/Canvasitems/CanvasItem.hs +2/−0
• HTk/Devices/Printer.hs +2/−1
• HTk/Kernel/ButtonWidget.hs +4/−2
• HTk/Kernel/Wish.hs +2/−1
• HTk/Toolkit/FileDialog.hs +8/−6
• HTk/Toolkit/InputForm.hs +34/−39
• HTk/Toolkit/InputWin.hs +11/−5
• HTk/Toolkit/LogWin.hs +6/−1
• HTk/Toolkit/ModalDialog.hs +6/−2
• HTk/Widgets/Canvas.hs +4/−1
• HTk/Widgets/Editor.hs +13/−7
• HTk/Widgets/Entry.hs +5/−2
• HTk/Widgets/ListBox.hs +4/−1
• uni-htk.cabal +4/−7

@@ -28,6 +28,7 @@  ) where +import Control.Exception import Data.List (intersperse)  import HTk.Widgets.Canvas@@ -61,6 +62,7 @@   coord co item =     do       try (execMethod item (\nm -> tkCoordItem nm co))+        :: IO (Either SomeException ())       return item   -- Gets the coord(s) of a canvas item on the parent canvas.   getCoord item =  evalMethod item (\nm -> tkGetCoordItem nm)

@@ -23,7 +23,7 @@   import Data.Char(isSpace)-import Control.Exception (try)+import Control.Exception  import HTk.Kernel.Core import HTk.Kernel.Geometry@@ -43,6 +43,7 @@       confstr <- showCreationConfigs confs       try         (execMethod target (\nm -> [tkPostScript nm confstr]))+        :: IO (Either SomeException ())       return ()     where tkPostScript :: ObjectName -> String -> TclCmd           tkPostScript name confstr =

@@ -9,7 +9,7 @@ import HTk.Kernel.Core import HTk.Kernel.BaseClasses(Widget) import HTk.Kernel.Configuration-import Control.Exception (try)+import Control.Exception  -- ----------------------------------------------------------------------- -- class ButtonWidget@@ -21,7 +21,9 @@   flash   :: w -> IO ()   -- Invokes the given button widget.   invoke  :: w -> IO ()-  flash w  = do {try(execMethod w (\ nm -> tkFlash nm)); return ()}+  flash w  = do+    try(execMethod w (\ nm -> tkFlash nm)) :: IO (Either SomeException ())+    return ()   invoke w = execMethod (toGUIObject w) (\ nm -> tkInvoke nm)  tkFlash :: ObjectName -> TclScript

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | HTk - a GUI toolkit for Haskell  -  (c) Universitaet Bremen -- -----------------------------------------------------------------------@@ -463,7 +464,7 @@       destroy <- spawnEvent(forever(          do             next <--               always (Control.Exception.catch (readCalledWish calledWish)                                    (\_-> return "OK Terminated"))+               always (Control.Exception.catch (readCalledWish calledWish)                                    (\ (_ :: SomeException) -> return "OK Terminated"))             send wishInChannel (typeWishAnswer next)          ))       return (listen wishInChannel,destroy)

@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+ -- | HTk\'s /file dialog box/. module HTk.Toolkit.FileDialog (   fileDialogStr,@@ -33,10 +35,10 @@   -- Display a warning window with a meaningful error message-ioErrorWindow :: Exception -> IO ()+ioErrorWindow :: SomeException -> IO () ioErrorWindow excep =   warningMess ("Error while reading directory:\n"++-     case ioErrors excep of+     case fromException excep of         Just ioe ->            ioeGetErrorString ioe++"\n"++            case ioeGetFileName ioe of@@ -45,7 +47,7 @@         Nothing -> "Exception: "++show excep++"\n"     ) -tryGetFilesAndFolders :: FilePath -> Bool -> IO (Either Exception+tryGetFilesAndFolders :: FilePath -> Bool -> IO (Either SomeException                                                         ([FilePath], [FilePath])) tryGetFilesAndFolders path showhidden =   do@@ -159,7 +161,7 @@                 setTkVariable file_var ""                 return True            Left excep ->-              case ioErrors excep of+              case fromException excep of                  Just error | isPermissionError error -> return False                  Nothing ->                     do@@ -642,7 +644,7 @@                                showhidden <- getRef showhiddenref                                refresh foldersref filesref pathref                                  folderslb fileslb showhidden-                           Left _ ->+                           Left (_ :: SomeException) ->                              status #                                text                                  ("Error: Couldn't create folder '" ++@@ -711,7 +713,7 @@                                    showhidden <- getRef showhiddenref                                    refresh foldersref filesref pathref                                      folderslb fileslb showhidden-                               Left _ ->+                               Left (_ :: SomeException) ->                                  status #                                    text                                      ("Error: Could not delete file '" ++

@@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | the inputform module HTk.Toolkit.InputForm (@@ -35,6 +36,8 @@         ) where +import Control.Exception+ import Util.Messages import HTk.Kernel.Core import qualified HTk.Toplevel.HTk as HTk (font)@@ -288,16 +291,14 @@         modifier f fe@(EntryField pr lbl pv) = synchronize fe (do {                 setReplacorCmd pv cmd;                 return fe-                }) where cmd r = do {-                          ans <- try (getVar fe);+                }) where cmd r = do+                          ans <- try (getVar fe)                           case ans of-                                  (Left e) -> do {-                                          txt <- getText lbl;-                                          errorMess (txt++" legal field value");+                                  Left (e :: SomeException) -> do+                                          txt <- getText lbl+                                          errorMess (txt++" legal field value")                                           raise illegalGUIValue-                                          }-                                  (Right val) -> return (f r val)-                          }+                                  Right val -> return (f r val)  -- -------------------------------------------------------------------------- --  Numeric Entry Fields@@ -326,10 +327,12 @@         pack lbl [Expand Off, Fill X]         pr <- newEntry b []         pack pr [Fill X, Expand Off]-        sp <- newSpinButton b (\sp-> do tv<- try (getValue pr);-                                        case tv of-                                          Right v -> pr # value (spin sp v)-                                          Left _  -> return pr) []+        sp <- newSpinButton b+          (\sp-> do+             tv <- try (getValue pr);+             case tv of+               Right v -> pr # value (spin sp v)+               Left (_ :: SomeException)  -> return pr) []         pack sp [Expand Off]         pv <- newFieldInf                 (\c -> do {bg (toColour c) pr; done})@@ -393,26 +396,23 @@                 synchronize fe $ do {                 setReplacorCmd pv cmd;                 return fe-                } where cmd r = do {-                          ans <- try (getVar fe);+                } where cmd r = do+                          ans <- try (getVar fe)                           case ans of-                                  (Left e) -> do {-                                          txt <- getText lbl;-                                          errorMess ("Illegal field value for "++ txt);+                                  Left (e :: SomeException) -> do+                                          txt <- getText lbl+                                          errorMess ("Illegal field value for "++ txt)                                           raise illegalGUIValue-                                          }-                                  (Right val) -> return (f r val) {- do+                                  Right val -> return (f r val) {- do                                           num <- try ((readIO val) :: IO b)                                           case num of                                             Left _ -> do txt <- getText lbl                                                          createErrorWin-                                                           ("Not a numeric                                                          \value for field "+                                                           ("Not a numeric " +++                                                            "value for field "                                                             ++ txt) []                                             Right _ -> return (f r val) -}-                          } -- -- -------------------------------------------------------------------------- --  Checkbox Fields -- --------------------------------------------------------------------------@@ -497,17 +497,14 @@         modifier f fe@(CheckboxField pr lbl cbv pv) = synchronize fe (do {                 setReplacorCmd pv cmd;                 return fe-                }) where cmd r = do {-                          ans <- try (getVar fe);+                }) where cmd r = do+                          ans <- try (getVar fe)                           case ans of-                                  (Left e) -> do {-                                          txt <- getText lbl;-                                          errorMess (txt++" legal field value");+                                  Left (e :: SomeException) -> do+                                          txt <- getText lbl+                                          errorMess (txt++" legal field value")                                           raise illegalGUIValue-                                          }-                                  (Right val) -> return (f r val)-                          }-+                                  Right val -> return (f r val)  -- -------------------------------------------------------------------------- --  Text Fields@@ -589,16 +586,14 @@         modifier f fe@(TextField tp lbl pv) = synchronize fe (do {                 setReplacorCmd pv cmd;                 return fe-                }) where cmd r = do {-                          ans <- try (getVar fe);+                }) where cmd r = do+                          ans <- try (getVar fe)                           case ans of-                            Left err -> do {-                                   txt <- getText lbl;-                                   errorMess (txt++" legal field value");+                            Left (err :: SomeException) -> do+                                   txt <- getText lbl+                                   errorMess (txt++" legal field value")                                    raise illegalGUIValue-                                   }                             Right val -> return (f r val)-                          }   -- --------------------------------------------------------------------------

@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+ -- | Basic input window for record values and their fields. module HTk.Toolkit.InputWin (         InputWin,@@ -8,6 +10,8 @@         waitValidate         ) where +import Control.Exception+ import HTk.Kernel.Core import HTk.Toplevel.HTk import HTk.Widgets.Space@@ -164,11 +168,13 @@   True  -> do             res <- try (getFormValue form)             case res of-             Left  e -> internalWait win val mod-             Right res' -> do chck <- val res'-                              if chck then do destroy win-                                              return (Just res')-                                      else internalWait win val mod+             Left (e :: SomeException) -> internalWait win val mod+             Right res' -> do+                 chck <- val res'+                 if chck then do+                     destroy win+                     return (Just res')+                   else internalWait win val mod  initiate :: InputForm a -> Maybe a -> IO () initiate form Nothing = done

@@ -10,6 +10,8 @@  ) where +import Control.Exception+ import System.IO.Unsafe import Reactor.ReferenceVariables import HTk.Toplevel.HTk@@ -70,7 +72,9 @@   do selev <- fileDialog "Open file" pathRef      file  <- sync selev      case file of-       Just fp -> try (writeTextToFile ed fp) >> done+       Just fp -> do+         try (writeTextToFile ed fp) :: IO (Either SomeException ())+         done        _ -> done  @@ -103,5 +107,6 @@ writeLogWin lw@(LogWin _ ed _) str =   do     try (insertText ed EndOfText str)+      :: IO (Either SomeException ())     moveto Vertical ed 1.0     done

@@ -5,6 +5,8 @@  ) where +import Control.Exception+ import HTk.Toplevel.HTk  -- -----------------------------------------------------------------------@@ -39,8 +41,10 @@   gw <- getCurrentGrab   grabLocal win   ans <- sync ev-  try(releaseGrab win)-  when destr (do {try (destroy win);done})+  try(releaseGrab win) :: IO (Either SomeException ())+  when destr $ do+    try (destroy win) :: IO (Either SomeException ())+    return ()   returnGrab gw   return ans 

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | HTk's <strong>canvas widget</strong>.<br> -- A canvas is a drawing pad, that can also contain widgets in embedded@@ -27,6 +28,8 @@  ) where +import Control.Exception+ import HTk.Kernel.Core import HTk.Kernel.BaseClasses(Widget) import HTk.Kernel.Configuration@@ -174,7 +177,7 @@       objnm <- getObjectName (toGUIObject item)       ans <- try (evalMethod cnv (\nm -> tkBBox nm objnm))       case ans of-        Left e -> return Nothing+        Left (e :: SomeException) -> return Nothing         Right a -> return (Just a)  tkBBox :: ObjectName -> ObjectName -> TclScript

@@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | HTk\'s /editor widget/. -- A text container for editing purposes. An editor widget can contain@@ -47,6 +48,9 @@  ) where +import Control.Exception+import Data.Char(isSpace)+ import HTk.Kernel.Core import HTk.Kernel.BaseClasses(Widget) import HTk.Kernel.Configuration@@ -57,7 +61,7 @@ import HTk.Devices.XSelection import HTk.Components.ICursor import HTk.Components.Index-import Data.Char(isSpace)+ import Util.Computation import Events.Destructible import Events.Synchronized@@ -280,6 +284,7 @@ appendText ed str =   do     try (insertText ed EndOfText str)+      :: IO (Either SomeException ())     moveto Vertical ed 1.0     done @@ -326,8 +331,9 @@     do       binx <- getBaseIndex w i       ans <- try (evalMethod w (\nm -> [tkBBox nm (binx::BaseIndex)]))-      case ans of (Left e)  -> return Nothing-                  (Right v) -> return (Just v)+      case ans of+        Left (e :: SomeException)  -> return Nothing+        Right v -> return (Just v)     where tkBBox nm i = show nm ++ " bbox " ++ show i  @@ -507,14 +513,14 @@         getSelectionStart tp = do                 mstart <- try (evalMethod tp (\nm -> tkSelFirst nm))                 case mstart of-                        (Left e)  -> return Nothing -- actually a tk error-                        (Right v) -> (return . Just) v+                        Left (e :: SomeException)  -> return Nothing -- actually a tk error+                        Right v -> return $ Just v         -- Gets the end index of the editor\'s selection.         getSelectionEnd tp = do                 mstart <- try (evalMethod tp (\nm -> tkSelEnd nm))                 case mstart of-                        (Left e)  -> return Nothing -- actually a tk error-                        (Right v) -> (return . Just) v+                        Left (e :: SomeException)  -> return Nothing -- actually a tk error+                        Right v -> return $ Just v  -- | You can select a text range inside an editor widget. instance (

@@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | HTk's <strong>entry field</strong>.<br> -- A simple widget that displays an editable line of text.@@ -17,6 +18,8 @@  ) where +import Control.Exception+ import HTk.Kernel.Core import HTk.Kernel.BaseClasses(Widget) import HTk.Kernel.Configuration@@ -241,7 +244,7 @@       mstart <-         try (evalMethod ent (\nm -> [show nm ++ " index sel.first "]))       case mstart of-        Left e -> return Nothing     -- actually a tk error+        Left (e :: SomeException) -> return Nothing     -- actually a tk error         Right v -> return (Just v)   -- Gets the end index of the entry\'s selection.   getSelectionEnd ent =@@ -249,7 +252,7 @@       mend <-         try (evalMethod ent (\nm -> [show nm ++ " index sel.last "]))       case mend of-        Left e -> return Nothing    -- actually a tk error+        Left (e :: SomeException) -> return Nothing    -- actually a tk error         Right v -> return (Just v)  -- | An editor widget has an X selection.

@@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | HTk\'s /listbox widget/ . -- A scrollable widget that displays a set of text lines with selection@@ -23,7 +24,9 @@  ) where +import Control.Exception import Data.List+ import HTk.Kernel.Core import HTk.Kernel.BaseClasses(Widget) import HTk.Kernel.Configuration@@ -169,7 +172,7 @@     do       binx <- getBaseIndex w i       ans <- try (evalMethod w (\nm -> [tkBBox nm (binx::Int)]))-      case ans of Left e  -> return Nothing+      case ans of Left (e :: SomeException)  -> return Nothing                   Right v -> return (Just v)     where tkBBox nm i = show nm ++ " bbox " ++ show i 

@@ -1,5 +1,5 @@ name:           uni-htk-version:        2.2.0.0+version:        2.2.1.0 build-type:     Simple license:        LGPL license-file:   LICENSE@@ -10,7 +10,7 @@ synopsis:       Graphical User Interface for Haskell Programs description:    GUI toolkit based on Tcl\/Tk cabal-version:  >= 1.4-Tested-With:    GHC==6.8.3, GHC==6.10.4, GHC==6.12.3+Tested-With:    GHC==6.10.4, GHC==6.12.3  flag debug   description: add debug traces@@ -55,7 +55,7 @@   HTk.Toolkit.SimpleForm, HTk.Toolkit.SimpleListBox, HTk.Toolkit.SpinButton,   HTk.Toolkit.TextDisplay, HTk.Toolkit.TreeList - build-depends: base >=3 && < 4, containers, directory, uni-util, uni-events,+ build-depends: base >=4 && < 5, containers, directory, uni-util, uni-events,   uni-posixutil, uni-reactor  -- extensions: OverlappingInstances@@ -63,7 +63,4 @@  if flag(debug)    cpp-options: -DDEBUG - if impl(ghc < 6.10)-   extensions: PatternSignatures- else-   ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations+ ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations