sifflet-0.1.5: GtkUtil.hs

{-# LANGUAGE CPP #-}

module GtkUtil (suppressScimBridge,
                createDialog, defaultDialogPosition, 
                runDialogM, runDialogS, 
                -- runDialogHelper,
                showInputErrorMessage, showErrorMessage, showInfoMessage,
                showMessage,
                EntryDialog, Reader, 
                createEntryDialog, runEntryDialog,
                addEntryWithLabel
               )

where

#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) 
import System.Posix.Env
#endif
import Graphics.UI.Gtk

import Util

-- SCIM Bridge causes problems, so shush it

suppressScimBridge :: IO ()
suppressScimBridge = 
#if defined(mingw32_HOST_OS) || defined(__MINGW32__) 
    return ()
#else
    putEnv "GTK_IM_MODULE=gtk-im-context-simple"
#endif

-- ============================================================
-- CUSTOMIZABLE DIALOGS

createDialog :: String -> (VBox -> IO a) -> IO (Dialog, a)
createDialog title addContent = do
  -- Create basic dialog
  dialog <- dialogNew
  windowSetTitle dialog title
  widgetSetName dialog ("Sifflet-" ++ title)

  -- Add custom content
  vbox <- dialogGetUpper dialog
  content <- addContent vbox

  -- Add standard buttons
  dialogAddButton dialog "OK" ResponseOk
  dialogAddButton dialog "Cancel" ResponseCancel
  dialogSetDefaultResponse dialog ResponseOk -- has no effect?

  return (dialog, content)

-- | Where to put a dialog window.
-- Possible values are
-- WinPosNone WinPosCenter WinPosMouse WinPosCenterAlways 
-- WinPosCenterOnParent

defaultDialogPosition :: WindowPosition
defaultDialogPosition = WinPosMouse

-- | Customizable framework for running a dialog

runDialogS :: Dialog -> a -> (a -> IO (SuccFail b)) -> IO (Maybe b)
runDialogS dialog inputs processInputs = 
    runDialogHelper dialog inputs processInputs True

runDialogM :: Dialog -> a -> (a -> IO (Maybe b)) -> IO (Maybe b)
runDialogM dialog inputs processInputs =
    let process' inputs' = do
          result <- processInputs inputs'
          case result of
            Nothing -> return $ Fail "_Nothing_"
            Just value -> return $ Succ value
    in runDialogHelper dialog inputs process' False

runDialogHelper :: Dialog -> a -> (a -> IO (SuccFail b)) -> Bool -> IO (Maybe b)
runDialogHelper dialog inputs processInputs retryOnError = do
  -- Position and show the dialog
  windowSetPosition dialog defaultDialogPosition
  widgetShowAll dialog
  windowPresent dialog

  let run = do
        respId <- dialogRun dialog
        return Nothing
        case respId of
          ResponseOk ->
              do
                result <- processInputs inputs
                case result of
                  Fail msg ->
                      if retryOnError
                      then do
                        showErrorMessage msg
                        run -- try again
                      else finish Nothing
                  Succ value -> finish (Just value)
          _ -> finish Nothing

      finish result = do
              widgetDestroy dialog
              return result

  run

showInputErrorMessage :: String -> IO ()
showInputErrorMessage message =
    showErrorMessage ("Input Error:\n" ++ message)

showErrorMessage :: String -> IO ()
showErrorMessage = showMessage (Just "Error") MessageError ButtonsClose

showInfoMessage :: String -> String -> IO ()
showInfoMessage title = showMessage (Just title) MessageInfo ButtonsClose

showMessage :: Maybe String -> MessageType -> ButtonsType -> String -> IO ()
showMessage mtitle messagetype buttonstype message = do
  {
    msgDialog <- 
        messageDialogNew
        Nothing -- ? or (Just somewindow) -- what does this do?
        [] -- flags
        messagetype
        buttonstype
        message
  ; case mtitle of
      Nothing -> widgetSetName msgDialog "Sifflet-dialog"
      Just title -> windowSetTitle msgDialog title >>
                    widgetSetName msgDialog ("Sifflet-" ++ title)
  ; windowSetPosition msgDialog defaultDialogPosition
  ; windowPresent msgDialog
  ; dialogRun msgDialog
  ; widgetDestroy msgDialog
  }

-- ============================================================
-- INPUT DIALOGS

type Reader a b = (a -> SuccFail b)

data EntryDialog a = EntryDialog Dialog [Entry] (Reader [String] a)

createEntryDialog :: 
    String -> [String] -> [String] -> (Reader [String] a) -> Int -> 
    IO (EntryDialog a)
createEntryDialog title labels defaults reader width = do
  -- Interpret width = -1 as don't care

  (dialog, entries) <- 
      createDialog title (addEntries labels defaults)
  windowSetDefaultSize dialog width (-1)
  return $ EntryDialog dialog entries reader

runEntryDialog :: (Show a) => EntryDialog a -> IO (Maybe a)
runEntryDialog (EntryDialog dialog entries reader) = 
    let -- processInputs :: [Entry] -> IO (SuccFail a)
        -- weird error like in runComboBoxDialog    ^
        processInputs entries' = do
          inputs <- mapM entryGetText entries'
          return (reader inputs)

    in runDialogS dialog entries processInputs

addEntries :: [String] -> [String] -> VBox -> IO [Entry]
addEntries labels defaults vbox = do
  entries <- mapM (const entryNew) labels
  mapM_ (addEntryWithLabel vbox) (zip3 labels entries defaults)
  return entries

-- | Add a labeled text entry to the vbox.

addEntryWithLabel :: VBox -> (String, Entry, String) -> IO ()
addEntryWithLabel vbox (name, entry, defaultValue) = do
    label <- labelNew (Just name)
    entrySetText entry defaultValue
    boxPackStartDefaults vbox label
    boxPackStartDefaults vbox entry