module HTk.Toolkit.InputWin (
InputWin,
createInputWin,
createInputWin',
wait,
waitValidate
) where
import Control.Exception
import HTk.Kernel.Core
import HTk.Toplevel.HTk
import HTk.Widgets.Space
import HTk.Toolkit.SelectBox
import HTk.Toolkit.ModalDialog
import HTk.Toolkit.InputForm
import Reactor.ReferenceVariables
import HTk.Toolkit.Separator
data InputWin a = InputWin {
fWindow :: Toplevel,
fForm :: InputForm a,
fEvents :: (Event Bool)
}
instance GUIObject (InputWin a) where
toGUIObject iwin = toGUIObject (fWindow iwin)
cname iwin = cname (fWindow iwin)
createInputWin' :: String
-> [Config Message]
-> (Box -> IO (InputForm a))
-> [Config Toplevel]
-> IO (InputWin a, InputForm a)
createInputWin' str hdconfs ifun tpconfs =
delayWish $ do
tp <- createToplevel ([text "Input Form Window"]++tpconfs)
pack tp [Expand On, Fill Both]
b <- newVBox tp []
pack b [Expand On, Fill Both]
let fmsg = xfont {family = Just Times, weight = Just Bold,
slant = Just Roman, points = (Just 180)}
msg <- newMessage b ([text str, borderwidth 0, aspect 750, font fmsg]++
hdconfs)
pack msg [Expand On, Fill Both, PadX (cm 0.5), PadY (cm 0.5)]
sp1 <- newSpace b (cm 0.15) []
pack sp1 [Expand Off, Fill X, Side AtTop]
newHSeparator b
sp2 <- newSpace b (cm 0.15) []
pack sp2 [Expand Off, Fill X, Side AtTop]
formbox <- newVBox b []
pack formbox [Expand On, Fill Both, PadX (cm 0.5)]
form <- ifun formbox
sp3 <- newSpace b (cm 0.15) []
pack sp3 [Expand Off, Fill X, Side AtBottom]
newHSeparator b
sp4 <- newSpace b (cm 0.15) []
pack sp4 [Expand Off, Fill X, Side AtBottom]
sb <- newSelectBox b Nothing []
pack sb [Expand Off, Fill X, Side AtBottom]
but1 <- addButton sb [text "Ok"] [Expand On, Side AtRight]
but2 <- addButton sb [text "Cancel"] [Expand On, Side AtRight]
clickedbut1 <- clicked but1
clickedbut2 <- clicked but2
let ev = (clickedbut1 >> (always (return True))) +> (clickedbut2 >> (always (return False)))
sp5 <- newSpace b (cm 0.3) []
pack sp5 [Fill X]
return ((InputWin tp form ev), form)
createInputWin :: String
-> (Box -> IO (InputForm a))
-> [Config Toplevel]
-> IO (InputWin a, InputForm a)
createInputWin str = createInputWin' str []
wait :: InputWin a
-> Bool
-> IO (Maybe a)
wait win@(InputWin tp form@(InputForm b e) ev) modality = do
fst <- getRef e
initiate form (fFormValue fst)
internalWait win (const (return True)) modality
waitValidate :: InputWin a
-> (a-> IO Bool)
-> Bool
-> IO (Maybe a)
waitValidate win@(InputWin tp form@(InputForm b e) ev) validate modality = do
fst <- getRef e
initiate form (fFormValue fst)
internalWait win validate modality
internalWait :: InputWin a -> (a-> IO Bool)-> Bool -> IO (Maybe a)
internalWait win@(InputWin tp form ev) val mod = do
ans <- modalInteraction tp False mod ev
case ans of
False -> do
destroy win
return Nothing
True -> do
res <- try (getFormValue form)
case res of
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
initiate form (Just val) = setFormValue form val