module Graphics.UI.Gtk.Windows.MessageDialog (
MessageDialog,
MessageDialogClass,
castToMessageDialog, gTypeMessageDialog,
toMessageDialog,
MessageType(..),
ButtonsType(..),
DialogFlags(..),
messageDialogNew,
messageDialogNewWithMarkup,
messageDialogSetMarkup,
messageDialogSetImage,
messageDialogSetSecondaryMarkup,
messageDialogSetSecondaryText,
messageDialogMessageType,
messageDialogText,
messageDialogUseMarkup,
messageDialogSecondaryText,
messageDialogSecondaryUseMarkup,
messageDialogImage,
messageDialogButtons,
messageDialogMessageArea,
) where
import Control.Monad (liftM)
import System.Glib.FFI
import Graphics.UI.Gtk.Types
import System.Glib.UTFString
import System.Glib.Attributes
import System.Glib.Properties
import System.Glib.Flags (Flags, fromFlags)
import Graphics.UI.Gtk.Abstract.Object (makeNewObject)
import Graphics.Rendering.Pango.Markup (Markup)
data MessageType = MessageInfo
| MessageWarning
| MessageQuestion
| MessageError
| MessageOther
deriving (Enum,Show,Eq)
data ButtonsType = ButtonsNone
| ButtonsOk
| ButtonsClose
| ButtonsCancel
| ButtonsYesNo
| ButtonsOkCancel
deriving (Enum,Show,Eq)
data DialogFlags = DialogModal
| DialogDestroyWithParent
| DialogNoSeparator
deriving (Show,Eq,Bounded)
instance Enum DialogFlags where
fromEnum DialogModal = 1
fromEnum DialogDestroyWithParent = 2
fromEnum DialogNoSeparator = 4
toEnum 1 = DialogModal
toEnum 2 = DialogDestroyWithParent
toEnum 4 = DialogNoSeparator
toEnum unmatched = error ("DialogFlags.toEnum: Cannot match " ++ show unmatched)
succ DialogModal = DialogDestroyWithParent
succ DialogDestroyWithParent = DialogNoSeparator
succ _ = undefined
pred DialogDestroyWithParent = DialogModal
pred DialogNoSeparator = DialogDestroyWithParent
pred _ = undefined
enumFromTo x y | fromEnum x == fromEnum y = [ y ]
| otherwise = x : enumFromTo (succ x) y
enumFrom x = enumFromTo x DialogNoSeparator
enumFromThen _ _ = error "Enum DialogFlags: enumFromThen not implemented"
enumFromThenTo _ _ _ = error "Enum DialogFlags: enumFromThenTo not implemented"
instance Flags DialogFlags
messageDialogNew
:: Maybe Window
-> [DialogFlags]
-> MessageType
-> ButtonsType
-> String
-> IO MessageDialog
messageDialogNew mWindow flags mType bType msg =
withUTFString (unPrintf msg) $ \msgPtr ->
makeNewObject mkMessageDialog $
liftM (castPtr :: Ptr Widget -> Ptr MessageDialog) $
call_message_dialog_new mWindow flags mType bType msgPtr
call_message_dialog_new :: Maybe Window -> [DialogFlags] ->
MessageType -> ButtonsType -> Ptr CChar ->
IO (Ptr Widget)
call_message_dialog_new (Just (Window fPtr)) flags mType bType msgPtr =
withForeignPtr fPtr $ \ptr ->
message_dialog_new ptr (fromIntegral (fromFlags flags))
(fromIntegral (fromEnum mType))
(fromIntegral (fromEnum bType)) msgPtr
call_message_dialog_new Nothing flags mType bType msgPtr =
message_dialog_new nullPtr (fromIntegral (fromFlags flags))
(fromIntegral (fromEnum mType))
(fromIntegral (fromEnum bType)) msgPtr
foreign import ccall unsafe "gtk_message_dialog_new"
message_dialog_new :: Ptr Window -> CInt -> CInt -> CInt ->
Ptr CChar -> IO (Ptr Widget)
messageDialogNewWithMarkup
:: Maybe Window
-> [DialogFlags]
-> MessageType
-> ButtonsType
-> Markup
-> IO MessageDialog
messageDialogNewWithMarkup mWindow flags mType bType msg = do
md <- makeNewObject mkMessageDialog $
liftM (castPtr :: Ptr Widget -> Ptr MessageDialog) $
call_message_dialog_new mWindow flags mType bType nullPtr
messageDialogSetMarkup md msg
return md
messageDialogSetMarkup :: MessageDialogClass self => self
-> Markup
-> IO ()
messageDialogSetMarkup self str =
withUTFString (unPrintf str) $ \strPtr ->
(\(MessageDialog arg1) arg2 -> withForeignPtr arg1 $ \argPtr1 ->gtk_message_dialog_set_markup argPtr1 arg2)
(toMessageDialog self)
strPtr
messageDialogSetSecondaryMarkup :: MessageDialogClass self => self
-> String
-> IO ()
messageDialogSetSecondaryMarkup self str =
withUTFString (unPrintf str) $ \strPtr ->
let (MessageDialog fPtr) = toMessageDialog self in
withForeignPtr fPtr $ \ptr ->
message_dialog_format_secondary_markup ptr strPtr
foreign import ccall unsafe "gtk_message_dialog_format_secondary_markup"
message_dialog_format_secondary_markup :: Ptr MessageDialog ->
Ptr CChar -> IO ()
messageDialogSetSecondaryText :: MessageDialogClass self => self
-> String
-> IO ()
messageDialogSetSecondaryText self str =
withUTFString str $ \strPtr ->
let (MessageDialog fPtr) = toMessageDialog self in
withForeignPtr fPtr $ \ptr ->
message_dialog_format_secondary_text ptr strPtr
foreign import ccall unsafe "gtk_message_dialog_format_secondary_text"
message_dialog_format_secondary_text :: Ptr MessageDialog ->
Ptr CChar -> IO ()
messageDialogSetImage :: (MessageDialogClass self, WidgetClass image) => self
-> image
-> IO ()
messageDialogSetImage self image =
(\(MessageDialog arg1) (Widget arg2) -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->gtk_message_dialog_set_image argPtr1 argPtr2)
(toMessageDialog self)
(toWidget image)
messageDialogMessageType :: MessageDialogClass self => Attr self MessageType
messageDialogMessageType = newAttrFromEnumProperty "message-type"
gtk_message_type_get_type
messageDialogText :: MessageDialogClass self => Attr self (Maybe String)
messageDialogText = newAttrFromMaybeStringProperty "text"
messageDialogUseMarkup :: MessageDialogClass self => Attr self Bool
messageDialogUseMarkup = newAttrFromBoolProperty "use-markup"
messageDialogSecondaryText :: MessageDialogClass self => Attr self (Maybe String)
messageDialogSecondaryText = newAttrFromMaybeStringProperty "secondary-text"
messageDialogSecondaryUseMarkup :: MessageDialogClass self => Attr self Bool
messageDialogSecondaryUseMarkup = newAttrFromBoolProperty "secondary-use-markup"
messageDialogImage :: (MessageDialogClass self, WidgetClass widget) => ReadWriteAttr self Widget widget
messageDialogImage = newAttrFromObjectProperty "image"
gtk_widget_get_type
messageDialogButtons :: MessageDialogClass self => WriteAttr self ButtonsType
messageDialogButtons = writeAttrFromEnumProperty "buttons"
gtk_buttons_type_get_type
messageDialogMessageArea :: MessageDialogClass self => ReadAttr self VBox
messageDialogMessageArea = readAttrFromObjectProperty "message-area"
gtk_vbox_get_type
unPrintf :: String -> String
unPrintf [] = []
unPrintf ('%':xs) = '%':'%':unPrintf xs
unPrintf (x:xs) = x:unPrintf xs
foreign import ccall safe "gtk_message_dialog_set_markup"
gtk_message_dialog_set_markup :: ((Ptr MessageDialog) -> ((Ptr CChar) -> (IO ())))
foreign import ccall safe "gtk_message_dialog_set_image"
gtk_message_dialog_set_image :: ((Ptr MessageDialog) -> ((Ptr Widget) -> (IO ())))
foreign import ccall unsafe "gtk_message_type_get_type"
gtk_message_type_get_type :: CUInt
foreign import ccall unsafe "gtk_widget_get_type"
gtk_widget_get_type :: CUInt
foreign import ccall unsafe "gtk_buttons_type_get_type"
gtk_buttons_type_get_type :: CUInt
foreign import ccall unsafe "gtk_vbox_get_type"
gtk_vbox_get_type :: CUInt