module HTk.Toolkit.SimpleForm(
Form,
newFormEntry,
emptyForm,
nullForm,
newFormMenu,
newFormOptionMenu,
newFormOptionMenu2,
(//),
(\\),
column,
row,
doForm,
doFormMust,
doFormList,
mapForm,
mapFormIO,
guardForm,
guardFormIO,
guardNothing,
FormValue(..),
mapMakeFormEntry,
FormTextField(..),
FormTextFieldIO(..),
Password(..),
FormLabel(..),
EmptyLabel(EmptyLabel),
WrappedFormLabel(..),
Radio(..),
HasConfigRadioButton(..),
editableTextForm,
editableTextForm0,
) where
import Data.Char
import Data.IORef
import Data.Typeable
import Util.ExtendedPrelude
import Util.BinaryAll(HasBinary(..),mapWrite,mapRead)
import Util.Messages
import Util.Computation
import Events.Events
import Events.Channels
import HTk.Toplevel.HTk
import HTk.Toolkit.HTkMenu
data EnteredForm value = EnteredForm {
packAction :: IO (),
getFormValue :: IO (WithError value),
destroyAction :: IO ()
}
mapEnteredForm :: (a -> b) -> EnteredForm a -> EnteredForm b
mapEnteredForm f
(EnteredForm{packAction = packAction,getFormValue = getFormValue,
destroyAction = destroyAction}) =
EnteredForm {packAction = packAction,destroyAction = destroyAction,
getFormValue = do
we1 <- getFormValue
return (mapWithError f we1)
}
mapEnteredForm' :: (a -> WithError b) -> EnteredForm a -> EnteredForm b
mapEnteredForm' f
(EnteredForm{packAction = packAction,getFormValue = getFormValue,
destroyAction = destroyAction}) =
EnteredForm {packAction = packAction,destroyAction = destroyAction,
getFormValue = do
we1 <- getFormValue
return (mapWithError' f we1)
}
mapEnteredFormIO' :: (a -> IO (WithError b)) -> EnteredForm a
-> EnteredForm b
mapEnteredFormIO' f
(EnteredForm{packAction = packAction,getFormValue = getFormValue,
destroyAction = destroyAction}) =
EnteredForm {packAction = packAction,destroyAction = destroyAction,
getFormValue = do
we1 <- getFormValue
mapWithErrorIO' f we1
}
newtype Form value = Form (forall container . Container container
=> container -> IO (EnteredForm value))
instance Functor Form where
fmap f (Form getEnteredForm0) =
let
getEnteredForm1 container =
do
enteredForm1 <- getEnteredForm0 container
return (mapEnteredForm f enteredForm1)
in
Form getEnteredForm1
mapForm :: (x -> WithError y) -> Form x -> Form y
mapForm f (Form getEnteredForm0) =
let
getEnteredForm1 container =
do
enteredForm1 <- getEnteredForm0 container
return (mapEnteredForm' f enteredForm1)
in
Form getEnteredForm1
mapFormIO :: (x -> IO (WithError y)) -> Form x -> Form y
mapFormIO f (Form getEnteredForm0) =
let
getEnteredForm1 container =
do
enteredForm1 <- getEnteredForm0 container
return (mapEnteredFormIO' f enteredForm1)
in
Form getEnteredForm1
infixr 8 //
(//) :: Form value1 -> Form value2 -> Form (value1,value2)
(//) (Form enterForm1) (Form enterForm2) =
let
enterForm container =
do
enteredForm1 <- enterForm1 container
enteredForm2 <- enterForm2 container
let
enteredForm = EnteredForm {
packAction = (
do
packAction enteredForm1
packAction enteredForm2
),
getFormValue = (
do
valueError1 <- getFormValue enteredForm1
valueError2 <- getFormValue enteredForm2
return (pairWithError valueError1 valueError2)
),
destroyAction = (
do
destroyAction enteredForm1
destroyAction enteredForm2
)
}
return enteredForm
in
Form enterForm
guardForm :: (x -> Bool) -> String -> Form x -> Form x
guardForm test mess =
mapForm (\x -> if test x then hasValue x else hasError mess)
guardFormIO :: (x -> IO Bool) -> String -> Form x -> Form x
guardFormIO test mess =
mapFormIO (\ x ->
do
res <- test x
return (if res then hasValue x else hasError mess)
)
guardNothing :: String -> Form (Maybe x) -> Form x
guardNothing mess =
mapForm (\ xOpt ->
case xOpt of
Nothing -> hasError mess
Just x -> hasValue x
)
(\\) :: Form x -> Form y -> Form (x,y)
(\\) (Form enterForm1) (Form enterForm2) =
let
enterForm container =
do
frame <- newFrame container []
frame1 <- newFrame frame []
enteredForm1 <- enterForm1 frame1
frame2 <- newFrame frame []
enteredForm2 <- enterForm2 frame2
let
enteredForm = EnteredForm {
packAction = (
do
packAction enteredForm1
pack frame1 [Side AtLeft]
packAction enteredForm2
pack frame2 [Side AtLeft]
pack frame []
),
getFormValue = (
do
valueError1 <- getFormValue enteredForm1
valueError2 <- getFormValue enteredForm2
return (pairWithError valueError1 valueError2)
),
destroyAction = (
do
destroyAction enteredForm1
destroyAction enteredForm2
)
}
return enteredForm
in
Form enterForm
infixr 9 \\
emptyForm :: Form ()
emptyForm = Form (\ container ->
return (EnteredForm {
packAction = done,
getFormValue = return (hasValue ()),
destroyAction = done
})
)
nullForm :: FormLabel label => label -> Form ()
nullForm label = newFormEntry label ()
emptyFormList :: Form [a]
emptyFormList = fmap (const []) emptyForm
column :: [Form value] -> Form [value]
column forms =
foldr
(\ form listForm -> fmap (uncurry (:)) (form // listForm))
emptyFormList
forms
row :: [Form value] -> Form [value]
row forms =
foldr
(\ form listForm -> fmap (uncurry (:)) (form // listForm))
emptyFormList
forms
doFormMust :: String -> Form value -> IO value
doFormMust title form =
do
(Just value) <- doForm1 False title form
return value
doForm :: String -> Form value -> IO (Maybe value)
doForm = doForm1 True
doForm1 :: Bool -> String -> Form value -> IO (Maybe value)
doForm1 canCancel title (Form enterForm) =
do
(toplevel,enteredForm,okEvent,cancelEvent) <- delayWish (
do
toplevel <- createToplevel [text title]
enteredForm0 <- enterForm toplevel
frame <- newFrame toplevel []
okButton <- newButton frame [text "OK"]
okEvent <- clicked okButton
packAction enteredForm0
pack okButton [Side AtLeft]
cancelEvent <-
if canCancel
then
do
cancelButton <- newButton frame [text "Cancel"]
pack cancelButton [Side AtRight]
clicked cancelButton
else
return never
(destroyEvent,cancelBind) <- bindSimple toplevel Destroy
let
enteredForm =
enteredForm0 {
destroyAction =
do
destroyAction enteredForm0
cancelBind
}
pack frame [Side AtTop]
return (toplevel,enteredForm,okEvent,cancelEvent +> destroyEvent)
)
let
handler =
(do
okEvent
always (
do
valueError <- getFormValue enteredForm
case fromWithError valueError of
Right value -> return (Just value)
Left err ->
do
errorMess err
sync handler
)
)
+> (do
cancelEvent
return Nothing
)
valueOpt <- sync handler
destroyAction enteredForm
destroy toplevel
return valueOpt
doFormList :: String -> [(Form x,String)] -> IO (Event (WithError x),IO ())
doFormList title (formList :: [(Form x,String)]) =
do
let
doOneForm :: Toplevel -> (Form x,String)
-> IO (Event (WithError x),IO ())
doOneForm toplevel (Form enterForm,buttonName) =
do
frame <- newFrame toplevel []
leftFrame <- newFrame frame []
enteredForm <- enterForm leftFrame
button <- newButton frame [text buttonName,anchor East]
clickEvent <- clicked button
packAction enteredForm
pack leftFrame [Side AtLeft,Anchor West]
pack button [Side AtRight,Anchor East]
pack frame [Side AtTop,Fill X]
let
handler = clickEvent >>> getFormValue enteredForm
return (handler,done)
(toplevel,enterResults) <- delayWish (
do
toplevel <- createToplevel [text title]
enterResults <- mapM (doOneForm toplevel) formList
return (toplevel,enterResults)
)
(destroyEvent,unbind) <- bindSimple toplevel Destroy
let
event0 = choose (map fst enterResults)
event1 = event0
+> (do
destroyEvent
return (fail "Window destroyed")
)
destroyWindow :: IO ()
destroyWindow =
do
mapM_ snd enterResults
unbind
destroy toplevel
return (event1,destroyWindow)
newFormEntry :: (FormLabel label,FormValue value) => label -> value
-> Form value
newFormEntry label value =
let
enterForm container =
do
frame <- newFrame container []
packLabel <- formLabel frame label
enteredForm1 <- makeFormEntry frame value
let
enteredForm = EnteredForm {
packAction = (
do
packLabel
packAction enteredForm1
pack frame [Side AtTop,Fill X]
),
getFormValue = getFormValue enteredForm1,
destroyAction = destroyAction enteredForm1
}
return enteredForm
in
Form enterForm
newFormMenu :: FormLabel label => label -> HTkMenu value -> Form (Maybe value)
newFormMenu label htkMenu =
let
enterForm container =
do
frame <- newFrame container []
packLabel <- formLabel frame label
enteredForm1 <- makeFormMenuEntry frame htkMenu
let
enteredForm = EnteredForm {
packAction = (
do
packLabel
packAction enteredForm1
pack frame [Side AtTop,Fill X]
),
getFormValue = getFormValue enteredForm1,
destroyAction = destroyAction enteredForm1
}
return enteredForm
in
Form enterForm
makeFormMenuEntry :: Frame -> HTkMenu value -> IO (EnteredForm (Maybe (value)))
makeFormMenuEntry frame htkMenu =
do
(menuButton,menuEvent) <- compileHTkMenu frame htkMenu
resultRef <- newIORef Nothing
killChannel <- newChannel
let
menuEventThread =
(do
menuClick <- menuEvent
always (writeIORef resultRef (Just menuClick))
menuEventThread
)
+> receive killChannel
_ <- spawnEvent menuEventThread
return (EnteredForm{
packAction = pack menuButton [],
getFormValue = (
do
valueOpt <- readIORef resultRef
return (hasValue valueOpt)
),
destroyAction = sync (send killChannel ())
})
newFormOptionMenu :: (GUIValue a) => [a] -> Form a
newFormOptionMenu options =
let
enterForm container =
do
optionMenu <- newOptionMenu container options []
return (EnteredForm {
packAction = pack optionMenu [],
getFormValue = (
do
val <- getValue optionMenu
return (hasValue val)
),
destroyAction = done
})
in
Form enterForm
newFormOptionMenu2 :: (Eq a,GUIValue a) => [(a,b)] -> Form b
newFormOptionMenu2 options =
let
form1 = newFormOptionMenu (map fst options)
in
fmap
(\ a0 -> case findJust
(\ (a1,b1) -> if a1 == a0 then Just b1 else Nothing)
options
of
Nothing -> error (
"SimpleForm.newFormOptionMenu2: HTk returned strange value")
Just b -> b
)
form1
class FormLabel label where
formLabel :: Frame -> label -> IO (IO ())
instance FormLabel String where
formLabel frame str =
do
label <- newLabel frame [text str,anchor West]
return (pack label [Side AtLeft,Fill X])
instance FormLabel Image where
formLabel frame image =
do
label <- newLabel frame [photo image]
return (pack label [Side AtLeft])
data WrappedFormLabel = forall label . FormLabel label
=> WrappedFormLabel label
instance FormLabel WrappedFormLabel where
formLabel frame (WrappedFormLabel label) = formLabel frame label
data EmptyLabel = EmptyLabel
instance FormLabel EmptyLabel where
formLabel _ _ = return done
class FormValue value where
makeFormEntry :: Frame -> value -> IO (EnteredForm value)
mapMakeFormEntry :: FormValue value2
=> (value1 -> value2) -> (value2 -> value1)
-> (Frame -> value1 -> IO (EnteredForm value1))
mapMakeFormEntry toValue2 fromValue2 frame value1 =
do
enteredForm <- makeFormEntry frame (toValue2 value1)
return (mapEnteredForm fromValue2 enteredForm)
class FormTextField value where
makeFormString :: value -> String
readFormString :: String -> WithError value
instance FormTextField String where
makeFormString str = str
readFormString str = hasValue str
allSpaces :: String -> Bool
allSpaces = all isSpace
instance (Num a,Show a,Read a) => FormTextField a where
makeFormString value = show value
readFormString str = case reads str of
[(value,rest)] | allSpaces rest -> hasValue value
_ -> hasError (show str ++ " is not a number")
instance FormTextField value => FormTextFieldIO value where
makeFormStringIO value = return (makeFormString value)
readFormStringIO value = return (readFormString value)
class FormTextFieldIO value where
makeFormStringIO :: value -> IO String
readFormStringIO :: String -> IO (WithError value)
instance FormTextFieldIO value => FormValue value where
makeFormEntry frame defaultVal =
do
defaultString <- makeFormStringIO defaultVal
contentsVariable <- createTkVariable defaultString
(entry :: Entry String) <- newEntry frame [variable contentsVariable]
let
getFormValue =
do
(contents :: String) <- readTkVariable contentsVariable
readFormStringIO contents
let
enteredForm = EnteredForm {
packAction = pack entry [Side AtRight,Fill X],
getFormValue = getFormValue,
destroyAction = done
}
return enteredForm
newtype Password value = Password value
instance FormTextFieldIO value => FormValue (Password value) where
makeFormEntry frame (Password defaultVal) =
do
defaultString <- makeFormStringIO defaultVal
contentsVariable <- createTkVariable defaultString
(entry :: Entry String)
<- newEntry frame [showText '.',variable contentsVariable]
let
getFormValue =
do
(contents :: String) <- readTkVariable contentsVariable
valueWE <- readFormStringIO contents
return (mapWithError Password valueWE)
let
enteredForm = EnteredForm {
packAction = pack entry [Side AtRight,Fill X],
getFormValue = getFormValue,
destroyAction = done
}
return enteredForm
instance FormTextFieldIO value => FormTextFieldIO (Maybe value) where
makeFormStringIO Nothing = return ""
makeFormStringIO (Just value) = makeFormStringIO value
readFormStringIO "" =
do
null <- readFormStringIO ""
return (case fromWithError null of
Left _ -> hasValue Nothing
Right x -> hasValue (Just x)
)
readFormStringIO str =
do
xWE <- readFormStringIO str
return (mapWithError Just xWE)
data Radio x = Radio x | NoRadio deriving (Typeable)
class HasConfigRadioButton value where
configRadioButton :: value -> Config (RadioButton Int)
instance (HasConfigRadioButton value,Bounded value,Enum value)
=> FormValue (Radio value) where
makeFormEntry frame rvalue =
do
let
minB :: value
minB = minBound
maxB :: value
maxB = maxBound
minBoundInt :: Int
minBoundInt = fromEnum minB
maxBoundInt :: Int
maxBoundInt = fromEnum maxB
fromRValue :: Radio value -> Int
fromRValue NoRadio = 1
fromRValue (Radio x) = fromEnum x minBoundInt
toRValue :: Int -> Radio value
toRValue (1) = NoRadio
toRValue i =
if i>= 0 && i<= maxBoundInt minBoundInt
then
Radio (toEnum (i+minBoundInt))
else error
("SimpleForm.toRValue - radio button with odd number:"++
show i)
radioVar <- createTkVariable (fromRValue rvalue)
packActions <- mapM
(\ val ->
do
radioButton <- newRadioButton frame [
configRadioButton val,
variable radioVar,
value (fromRValue (Radio val))
]
return (pack radioButton [Side AtLeft])
)
[minB .. maxB]
let
enteredForm = EnteredForm {
packAction = sequence_ packActions,
getFormValue =
do
valInt <- readTkVariable radioVar
return (hasValue (toRValue valInt)),
destroyAction = done
}
return enteredForm
instance (Monad m,HasBinary x m) => HasBinary (Radio x) m where
writeBin = mapWrite (\ radio -> case radio of
Radio x -> Just x
NoRadio -> Nothing
)
readBin = mapRead (\ xOpt -> case xOpt of
Just x -> Radio x
Nothing -> NoRadio
)
instance FormValue Bool where
makeFormEntry frame b =
do
boolVar <- createTkVariable b
checkButton <- newCheckButton frame [variable boolVar]
let
enteredForm = EnteredForm {
packAction = pack checkButton [Side AtLeft],
getFormValue = (
do
bool <- readTkVariable boolVar
return (hasValue bool)
),
destroyAction = done
}
return enteredForm
instance FormValue () where
makeFormEntry frame () =
return (
EnteredForm {
packAction = done,
getFormValue = return (hasValue ()),
destroyAction = done
}
)
editableTextForm :: [Config Editor] -> Form String
editableTextForm configs =
Form (\ container ->
do
editorFrame <- newFrame container []
editor <- newEditor editorFrame (configs ++ [wrap NoWrap])
scrollBar1 <- newScrollBar editorFrame [orient Vertical]
scrollBar2 <- newScrollBar container [orient Horizontal]
editor # scrollbar Vertical scrollBar1
editor # scrollbar Horizontal scrollBar2
return (EnteredForm {
packAction =
(do
pack editor [Side AtRight]
pack scrollBar1 [Side AtRight,Fill Y,Expand On]
pack editorFrame []
pack scrollBar2 [Side AtTop,Fill X,Expand On]
),
getFormValue = (
do
value <- getValue editor
return (hasValue value)
),
destroyAction = done
})
)
editableTextForm0 :: [Config Editor] -> Form String
editableTextForm0 configs =
Form (\ container ->
do
editorFrame <- newFrame container []
editor <- newEditor editorFrame (configs ++ [wrap NoWrap])
return (EnteredForm {
packAction =
(do
pack editor [Side AtRight]
pack editorFrame []
),
getFormValue = (
do
value <- getValue editor
return (hasValue value)
),
destroyAction = done
})
)