{-# LANGUAGE CPP #-}

module Graphics.UI.Sifflet.GtkUtil 
    (suppressScimBridge
    , showChoicesDialog, defaultDialogPosition
    , runDialogM, runDialogS
     -- , runDialogHelper
    , showInputErrorMessage, showErrorMessage
    , showInfoMessage
    , showMessage
    , EntryDialog, Reader
    , createEntryDialog, runEntryDialog
    , addEntryWithLabel
    )

where

import Control.Monad

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

import Graphics.UI.Sifflet.LittleGtk
import Language.Sifflet.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

-- | Show a message and a set of choices;
-- run the action corresponding to the selected choice.
-- The last argument is an action corresponding to the "Cancel" option
-- (a Cancel button is automatically inserted) and is also used for
-- strange actions like closing the dialog window.
-- A good value for this might be return ().
showChoicesDialog :: String -> String -> [String] -> [IO a] -> IO a -> IO a
showChoicesDialog title message options actions cancelAction = do
  -- Create basic dialog
  dialog <- dialogNew
  windowSetTitle dialog title
  widgetSetName dialog ("Sifflet-" ++ title)

  -- Add message
  vbox <- dialogGetUpper dialog
  label <- labelNew (Just message)
  boxPackStartDefaults vbox label
  widgetShowAll vbox

  -- Add buttons
  -- Work around bug in gtk2hs v. 0.10.0 and 0.10.1,
  -- which is fixed in darcs gtk2hs.
  -- fromResponse (ResponseUser i) requires i > 0.
  -- so zip [1..] instead of zip [0..]
  let allActions = actions ++ [cancelAction]
      allOptions = options ++ ["Cancel"]
      indexOptions = zip [1..] allOptions
      addButton (i, option) = 
        dialogAddButton dialog option (ResponseUser i)
  forM_ indexOptions addButton
  dialogGetActionArea dialog >>= widgetShowAll

  -- Run dialog
  response <- dialogRun dialog
  widgetDestroy dialog -- here? or after handling response?
  case response of
    ResponseUser i -> 
        let j = i - 1 -- work around bug described above
        in if j >= 0 && j < length allActions
           then allActions !! j
           else errcats ["showChoicesDialog: response index",
                         show j, "is out of range for actions"]
    _ -> cancelAction
          
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
        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