diff --git a/HTk/Canvasitems/CanvasItem.hs b/HTk/Canvasitems/CanvasItem.hs
--- a/HTk/Canvasitems/CanvasItem.hs
+++ b/HTk/Canvasitems/CanvasItem.hs
@@ -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)
diff --git a/HTk/Devices/Printer.hs b/HTk/Devices/Printer.hs
--- a/HTk/Devices/Printer.hs
+++ b/HTk/Devices/Printer.hs
@@ -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 =
diff --git a/HTk/Kernel/ButtonWidget.hs b/HTk/Kernel/ButtonWidget.hs
--- a/HTk/Kernel/ButtonWidget.hs
+++ b/HTk/Kernel/ButtonWidget.hs
@@ -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
diff --git a/HTk/Kernel/Wish.hs b/HTk/Kernel/Wish.hs
--- a/HTk/Kernel/Wish.hs
+++ b/HTk/Kernel/Wish.hs
@@ -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)
diff --git a/HTk/Toolkit/FileDialog.hs b/HTk/Toolkit/FileDialog.hs
--- a/HTk/Toolkit/FileDialog.hs
+++ b/HTk/Toolkit/FileDialog.hs
@@ -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 '" ++
diff --git a/HTk/Toolkit/InputForm.hs b/HTk/Toolkit/InputForm.hs
--- a/HTk/Toolkit/InputForm.hs
+++ b/HTk/Toolkit/InputForm.hs
@@ -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)
- }
-- --------------------------------------------------------------------------
diff --git a/HTk/Toolkit/InputWin.hs b/HTk/Toolkit/InputWin.hs
--- a/HTk/Toolkit/InputWin.hs
+++ b/HTk/Toolkit/InputWin.hs
@@ -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
diff --git a/HTk/Toolkit/LogWin.hs b/HTk/Toolkit/LogWin.hs
--- a/HTk/Toolkit/LogWin.hs
+++ b/HTk/Toolkit/LogWin.hs
@@ -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
diff --git a/HTk/Toolkit/ModalDialog.hs b/HTk/Toolkit/ModalDialog.hs
--- a/HTk/Toolkit/ModalDialog.hs
+++ b/HTk/Toolkit/ModalDialog.hs
@@ -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
diff --git a/HTk/Widgets/Canvas.hs b/HTk/Widgets/Canvas.hs
--- a/HTk/Widgets/Canvas.hs
+++ b/HTk/Widgets/Canvas.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | HTk's canvas widget.
-- 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
diff --git a/HTk/Widgets/Editor.hs b/HTk/Widgets/Editor.hs
--- a/HTk/Widgets/Editor.hs
+++ b/HTk/Widgets/Editor.hs
@@ -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 (
diff --git a/HTk/Widgets/Entry.hs b/HTk/Widgets/Entry.hs
--- a/HTk/Widgets/Entry.hs
+++ b/HTk/Widgets/Entry.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | HTk's entry field.
-- 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.
diff --git a/HTk/Widgets/ListBox.hs b/HTk/Widgets/ListBox.hs
--- a/HTk/Widgets/ListBox.hs
+++ b/HTk/Widgets/ListBox.hs
@@ -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
diff --git a/uni-htk.cabal b/uni-htk.cabal
--- a/uni-htk.cabal
+++ b/uni-htk.cabal
@@ -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