wxHaskell ダイアログ

ホーム   目次

この章では、wxHaskellのダイアログを説明します。


モードレスダイアログ

モードレスダイアログは、ダイアログを開いている間も、そのアプリケーションで、他の作業ができるダイアログです。

modeless.hs


module Main where

import Graphics.UI.WX

main :: IO ()
main = start gui

gui :: IO ()
gui = do
    f       <- frame  [text := "ウィンドウ"]
    d       <- window f []
    b       <- button f [text := "Show dialog", on command := showDialog d]
    set f   [layout := floatCenter (widget b), clientSize := sz 250 150]
    
    return ()
    where
        showDialog d= do
            dial    <- dialog d    [visible := True
                                    ,text := "ダイアログ"
                                    ,layout := floatCentre (label
                                    "Modeless dialog")
                                    ,clientSize := sz 200 100]
            return ()
    
win
mac
lin

ダイアログをずらして、ウィンドウの「Show dialog」ボタンを押してください。何個もダイアログを表示できます。

モーダルダイアログ

モーダルダイアログは、ダイアログを開いている間は、そのアプリケーションで、他の作業ができないダイアログです。

modal.hs


module Main where

import Graphics.UI.WX

main :: IO ()
main = start gui

gui :: IO ()
gui = do
    f       <- frame [text := "ウィンドウ"]
    d       <- window f []
    b       <- button f [text := "Show dialog", on command := showDialog d]
    set f   [layout := floatCenter (widget b), clientSize := sz 250 150]
    
    return ()
    where
        showDialog d = do
            dial    <- dialog d [text := "ダイアログ"]
            ok      <- button dial [text := "OK"]
            set dial    [layout := floatCentre $ column 10
                            [(label "Modal dialog")
                            ,(widget ok)]
                        ,clientSize := sz 200 100
                        ,defaultButton := ok]
            result  <- showModal dial (\stop -> set ok [on command := stop (Just 0)])
            return ()
    
win
mac
lin

ダイアログをずらして、ウィンドウの「Show dialog」ボタンを押してください。警告が出てウィンドウを線選択できないか、ボタンを押しても反応しません。

macでは、デフォルトボタンは機能しません。

メッセージ

wxHaskellには、メッセージと呼ばれる、便利なダイアログがいくつか用意されています。

message.hs


module Main where

import Graphics.UI.WX
import Graphics.UI.WX.Dialogs

main :: IO ()
main = start gui

gui :: IO ()
gui = do
    f       <- frame    [text := "メッセージ"]
    error   <- button f [text := "Error"
                        ,on command := errorDialog f "失敗"
                        "ファイルの読み込みに失敗しました。"]
    warning <- button f [text := "Warning"
                        ,on command := warningDialog f "警告"
                        "許可されていない操作です。"]
    info    <- button f [text := "Info"
                        ,on command := infoDialog f "情報"
                        "ダウンロードが完了しました。"]
    confirm <- button f [text := "Confirm"
                        ,on command := selectConfirm f]
    proceed <- button f [text := "Proceed"
                        ,on command := selectProceed f]
    set f   [layout := fill $ boxed "Messages" (grid 5 5
                [
                    [floatCenter (widget error), floatCenter (widget warning)],
                    [floatCenter (widget info),  floatCenter (widget confirm)],
                    [floatCenter (widget proceed)]
                ])
                ,clientSize := sz 250 150
            ]
    return ()
    where
        selectConfirm f = do
            confirmDialog f "確認" "本当に終了しますか?" False
            return ()
        selectProceed f = do
            proceedDialog f "削除してもよろしいですか?" "この操作は取り消せません。"
            return ()
    
起動画面
error
warning
info
confirm
proceed

カラーダイアログ

colorDialog.hs


module Main where

import Graphics.UI.WX
import Graphics.UI.WXCore

main :: IO ()
main = start gui

gui :: IO ()
gui = do
    f       <- frame    [text := "カラーダイアログ"]
    p       <- panel  f [bgcolor := green]
    b       <- button f [text := "Choose color", on command := chooseColor f p]
     
    set f   [layout :=  margin 5 $ column 0
                [row 0 [widget b, hfill(label "")]
                ,fill (boxed "color" (fill(widget p)))
                ]
            ,clientSize := sz 250 150
            ]
    return ()
    where
        chooseColor f p = do
            curCol  <- get p (bgcolor)
            newCol  <- colorDialog f curCol

            if newCol /= Nothing
            then do
                set p [bgcolor := col newCol]
            else do
                set p [bgcolor := curCol]
            refresh p
            where
                col :: (Maybe Color) -> Color
                col c =
                    case c of
                        Just x  -> x

    
win
mac
lin

フォントダイアログ

macでは、正常に動作します。

winでは、wxHaskellのフォントダイアログでは、すべてのフォントに下線がついてしまいます。

Linuxでは、文字化けしているフォントが多いです。

fontDialog.hs


module Main where

import Graphics.UI.WX

main :: IO ()
main = start gui

gui :: IO ()
gui = do
    f       <- frame        [text := "フォントダイアログ"]
    p       <- panel      f []
    s       <- staticText p [text := "app Design"]
    b       <- button     p [text := "Choose font", on command := chooseFont f s]
    
    set f   [layout := margin 5 $ container p $ column 0
                [widget b
                ,floatLeft (widget s)
                ]
            ,clientSize := sz 250 150
            ]
    
    return ()
    where
        chooseFont f s = do
            curFont <- get s (font)
            newFont <- fontDialog f curFont
            if newFont /= Nothing
            then do
                set s [font := unwrap newFont]
            else do
                set s [font := curFont]
            where
                unwrap :: (Maybe FontStyle) -> FontStyle
                unwrap wrapVal =
                    case wrapVal of
                        Just x -> x
    
win
mac
lin

ファイルオープンダイアログ

ファイルオープンダイアログの例として、Haskellファイルだけを開ける、「hsViewer」を作ってみました。実際にはすべてのテキストファイルを表示できますが、拡張子が「.hs」のファイルだけを表示するようにしました。なぜなら、画像ファイルとその他のファイルの区別はできるのですが、テキストファイルと実行ファイルの区別ができないのです。実行ファイルをテキストコントロールで開くと、アプリケーションがクラッシュしてしまします。そこで思い切って、「.hs」のファイルだけを表示できるようにしました。

Haskellファイル以外を選択した場合は、そのファイルのパスが表示されます。

hsViewer.hs


module Main where

import Graphics.UI.WX

main :: IO ()
main = start gui

gui :: IO ()
gui = do
    f       <- frame        [text := "hsViewer"]
    p       <- panel      f []
    t       <- textCtrl   p []
    m       <- menuPane     [text := "File"]
    about   <- menuAbout  m [on command := infoDialog f "hsViewer"
                            "Version 1.0\n© appdesign.jp"]
    open    <- menuItem   m [text := "Open",  on command := openFile f t]
    clear   <- menuItem   m [text := "Clear", on command := clearText t]
    sep     <- menuLine   m
    quit    <- menuQuit   m [on command := close f]
 
    set f   [layout := margin 5 $ container p $ fill (widget t)
            ,menuBar := [m]
            ,clientSize := sz 400 200
            ]
    return ()
    
    where
        openFile f t = do
            file    <-  fileOpenDialog f True True "Open file"
                        [("Haskell files",["*.hs"]),("Any file",["*.*"])] "" ""
            if file /= Nothing
            then do
                let path = unwrap file
                let len = length path
                let suf = drop (len -3 ) path
                if suf == ".hs"
                then do
                    str <- readFile path
                    set t [text := str]
                else do
                    set t [text := path]
            else do
                return ()
            where
                unwrap :: (Maybe FilePath) -> FilePath
                unwrap wrapVal =
                    case wrapVal of
                        Just x -> x
            
        clearText t = do
            set t [text := ""]
    
win
win
lin
lin


20859 visits
Posted: Jan. 10, 2019
Update: Jan. 11, 2019

ホーム   目次   ページトップ