Complex.hs

module View.Dialog.Complex (Layout (..),Widget (..),Modifier (..)
                           ,showDialog,showSimpleDialog
                           ,okLabel,okButton,cancelButton)
    where

import Control.Applicative ((<$>))
import Control.Monad (forM,forM_,foldM,when)
import Data.Char (isDigit)
import Graphics.UI.WX (Prop ((:=)),on)
import qualified Graphics.UI.WX as WX
import qualified Graphics.UI.WXCore as WXC
import View (View,frame)
import Util (justWhen,maybeRead)
import Util.Color (Color,fromWXColor,toWXColor)
import I18n (__)

data Widget a b = 
    ScrolledWindow (WX.Dialog () -> IO (WX.ScrolledWindow ()))
  | TextEntry (a -> String) (a -> String -> a)
  | NumberEntry (a -> Double) (a -> Double -> a)
  | Button String b
  | DefaultButton String b
  | TerminationButton String
  | ColorButton (a -> Color) (a -> Color -> a)
  | SingleListBox [String] (a -> Maybe Int) (a -> Maybe Int -> a)
  | MultiListBox [String] (a -> [Int]) (a -> [Int] -> a)
  | Spinner Int Int (a -> Int) (a -> Int -> a)
  | Choice [String] (a -> Int) (a -> Int -> a)
  | CheckBox String (a -> Bool) (a -> Bool -> a)
  | RadioBox String [String] (a -> Int) (a -> Int -> a)

data Modifier = HFill | Center | Margin | Boxed String | MinSize (Int,Int)

data WXWidget a b = 
    WXScrolledWindow (WX.ScrolledWindow ())
  | WXTextEntry (WX.TextCtrl ()) (a -> String -> a)
  | WXNumberEntry (WX.TextCtrl ()) (a -> Double -> a)
  | WXButton (WX.Button ()) b
  | WXTerminationButton (WX.Button ())
  | WXColorButton (WX.Button ()) (a -> Color -> a)
  | WXSingleListBox (WX.SingleListBox ()) (a -> Maybe Int -> a)
  | WXMultiListBox (WX.MultiListBox ()) (a -> [Int] -> a)
  | WXSpinCtrl (WX.SpinCtrl ()) (a -> Int -> a)
  | WXChoice (WX.Choice ()) (a -> Int -> a)
  | WXCheckBox (WX.CheckBox ()) (a -> Bool -> a)
  | WXRadioBox (WX.RadioBox ()) (a -> Int -> a)

instance WX.Widget (WXWidget a b) where
    widget (WXScrolledWindow ctrl) = WX.widget ctrl
    widget (WXTextEntry ctrl _) = WX.widget ctrl
    widget (WXNumberEntry ctrl _) = WX.widget ctrl
    widget (WXButton ctrl _) = WX.widget ctrl
    widget (WXTerminationButton ctrl) = WX.widget ctrl
    widget (WXColorButton ctrl _) = WX.widget ctrl
    widget (WXSingleListBox ctrl _) = WX.widget ctrl
    widget (WXMultiListBox ctrl _) = WX.widget ctrl
    widget (WXSpinCtrl ctrl _) = WX.widget ctrl
    widget (WXChoice ctrl _) = WX.widget ctrl
    widget (WXCheckBox ctrl _) = WX.widget ctrl
    widget (WXRadioBox ctrl _) = WX.widget ctrl

data Layout a b = Row [Layout a b]
                | Column [Layout a b]
                | Grid [[Layout a b]]
                | Label String
                | Modifier Modifier (Layout a b)
                | Modifiers [Modifier] (Layout a b)
                | Widget (Widget a b)
                | FocusOn (Widget a b)
                | WXWidget (WXWidget a b)

showDialog :: String -> Layout a b -> a -> View -> IO (Maybe (a,b))
showDialog caption layout defaultRecord view = do
  dialog <- WX.dialog (frame view) [WX.text := caption]
  layout' <- buildWXWidgets dialog layout defaultRecord

  WX.set dialog [WX.layout := buildWXLayout layout']

  WX.showModal dialog 
    (\endWith -> setButtonActions endWith defaultRecord layout')

showSimpleDialog :: String -> Layout a () -> a -> View -> IO (Maybe a)
showSimpleDialog caption layout defaultRecord view = 
    fmap fst <$> showDialog caption layout defaultRecord view

buildWXWidgets :: WX.Dialog () -> Layout a b -> a -> IO (Layout a b)
buildWXWidgets dialog layout record =
    let recBuild layout' = buildWXWidgets dialog layout' record
    in
      case layout of
        Row a -> Row <$> forM a recBuild
        Column a -> Column <$> forM a recBuild
        Grid a -> Grid <$> mapM (mapM recBuild) a
        Label a -> return $ Label a
        Modifier a b -> Modifier a <$> recBuild b
        Modifiers a b -> Modifiers a <$> recBuild b
        FocusOn a -> do (WXWidget w) <- recBuild $ Widget a
                        case w of  WXTextEntry c _ -> WX.focusOn c
                                   WXNumberEntry c _ -> WX.focusOn c
                                   WXButton c _ -> WX.focusOn c
                        return $ WXWidget w
        Widget (ScrolledWindow makeWindow) -> 
            (WXWidget . WXScrolledWindow) <$> makeWindow dialog
        Widget (TextEntry get set) ->
            do ctrl <- WX.textEntry dialog [WX.text := get record]
               return $ WXWidget $ WXTextEntry ctrl set
        Widget (NumberEntry get set) ->
            do ctrl <- WX.textEntry dialog [WX.text := show $ get record]
               WX.set ctrl [on WX.anyKey := numberEntryKeyHandler ctrl]
               return $ WXWidget $ WXNumberEntry ctrl set
        Widget (Button text action) -> 
            do ctrl <- WX.button dialog [WX.text := text]
               return $ WXWidget $ WXButton ctrl action
        Widget (DefaultButton text action) -> 
            do ctrl <- WX.button dialog [WX.text := text]
               WXC.buttonSetDefault ctrl
               return $ WXWidget $ WXButton ctrl action
        Widget (TerminationButton text) -> 
            do ctrl <- WX.button dialog [WX.text := text]
               return $ WXWidget $ WXTerminationButton ctrl
        Widget (ColorButton get set) -> 
            do ctrl <- WX.button dialog [ WX.bgcolor := toWXColor $ get record]               
               WX.set ctrl [on WX.command := do
                 color <- WX.get ctrl WX.bgcolor >>= WX.colorDialog dialog
                 justWhen color $ \c -> WX.set ctrl [WX.bgcolor := c]]
               return $ WXWidget $ WXColorButton ctrl set
        Widget (SingleListBox items get set) ->
            do ctrl <- WX.singleListBox dialog [WX.items := items]
               justWhen (get record) $ \selection -> 
                   WX.set ctrl [WX.selection := selection]
               return $ WXWidget $ WXSingleListBox ctrl set
        Widget (MultiListBox items get set) ->
            do ctrl <- WX.multiListBox dialog [WX.items := items]
               when (not $ null $ get record) $
                    WX.set ctrl [WX.selections := get record]
               return $ WXWidget $ WXMultiListBox ctrl set
        Widget (Spinner min max get set) ->
            do ctrl <- WX.spinCtrl dialog min max [WX.selection := get record]
               return $ WXWidget $ WXSpinCtrl ctrl set
        Widget (Choice items get set) ->
            do ctrl <- WX.choice dialog [ WX.items := items
                                        , WX.selection := get record]
               return $ WXWidget $ WXChoice ctrl set
        Widget (CheckBox text get set) ->
            do ctrl <- WX.checkBox dialog [ WX.text := text
                                          , WX.checked := get record]
               return $ WXWidget $ WXCheckBox ctrl set
        Widget (RadioBox text items get set) ->
            do ctrl <- WX.radioBox dialog WX.Vertical items
                       [WX.text := text, WX.selection := get record]
               return $ WXWidget $ WXRadioBox ctrl set

buildWXLayout :: Layout a b -> WX.Layout
buildWXLayout layout = 
    case layout of
      Row a -> WX.row 5 $ map buildWXLayout a
      Column a -> WX.column 5 $ map buildWXLayout a
      Grid rows -> WX.grid 5 5 $ map (map buildWXLayout) rows
      Label a -> WX.label a
      Modifier HFill a -> WX.hfill $ buildWXLayout a
      Modifier Center a -> WX.centre $ buildWXLayout a
      Modifier Margin a -> WX.margin 10 $ buildWXLayout a
      Modifier (Boxed text) a -> WX.boxed text $ buildWXLayout a
      Modifier (MinSize (x,y)) a -> WX.minsize (WXC.sz x y) $ buildWXLayout a
      Modifiers xs a -> buildWXLayout $ foldr Modifier a xs
      WXWidget a -> WX.widget a

setButtonActions :: (Maybe (a,b) -> IO ()) -> a -> Layout a b -> IO ()
setButtonActions endWith record completeLayout = 
    let recSet layout =
            case layout of
              Row a -> forM_ a recSet
              Column a -> forM_ a recSet
              Grid rows -> mapM_ (mapM_ recSet) rows
              Label _ -> return ()
              Modifier _ a -> recSet a
              Modifiers _ a -> recSet a
              WXWidget (WXTerminationButton button) ->
                  WX.set button [on WX.command := endWith Nothing]
              WXWidget (WXButton button action) ->
                  WX.set button [on WX.command := 
                    do result <- buildRecord record completeLayout
                       endWith $ Just (result,action)]
              WXWidget _ -> return ()      
    in
      recSet completeLayout

buildRecord :: a -> Layout a b -> IO a
buildRecord record layout = 
    case layout of
      Row a -> foldM buildRecord record a
      Column a -> foldM buildRecord record a
      Grid rows -> foldM (foldM buildRecord) record rows
      Label _ -> return record
      Modifier _ a -> buildRecord record a
      Modifiers _ a -> buildRecord record a
      WXWidget (WXScrolledWindow _) -> return record
      WXWidget (WXTextEntry ctrl set) -> 
          set record <$> WX.get ctrl WX.text
      WXWidget (WXNumberEntry ctrl set) -> do
          num <- maybeRead <$> WX.get ctrl WX.text
          case num of Just n -> return $ set record n
                      Nothing -> return record
      WXWidget (WXButton _ _) -> return record
      WXWidget (WXTerminationButton _) -> return record
      WXWidget (WXColorButton ctrl set) -> 
          (set record . fromWXColor) <$> WX.get ctrl WX.bgcolor
      WXWidget (WXSingleListBox ctrl set) -> 
          set record <$> getMaybeSelection ctrl
      WXWidget (WXMultiListBox ctrl set) -> 
          set record <$> WX.get ctrl WX.selections
      WXWidget (WXSpinCtrl ctrl set) -> set record <$> WX.get ctrl WX.selection
      WXWidget (WXChoice ctrl set) -> set record <$> WX.get ctrl WX.selection
      WXWidget (WXCheckBox ctrl set) -> set record <$> WX.get ctrl WX.checked
      WXWidget (WXRadioBox ctrl set) -> set record <$> WX.get ctrl WX.selection

    where
      getMaybeSelection ctrl = do
        selection <- WX.get ctrl WX.selection
        return $ if selection == -1 then Nothing else Just selection

numberEntryKeyHandler :: (WX.TextCtrl ()) -> WX.Key -> IO ()
numberEntryKeyHandler ctrl key = do
  text <- WX.get ctrl WX.text
  let lastCharIsDigit = (not $ null text) && 
                        (isDigit $ head $ reverse text)
  case key of
    WX.KeyChar '0' -> WX.propagateEvent
    WX.KeyChar '1' -> WX.propagateEvent
    WX.KeyChar '2' -> WX.propagateEvent
    WX.KeyChar '3' -> WX.propagateEvent
    WX.KeyChar '4' -> WX.propagateEvent
    WX.KeyChar '5' -> WX.propagateEvent
    WX.KeyChar '6' -> WX.propagateEvent
    WX.KeyChar '7' -> WX.propagateEvent
    WX.KeyChar '8' -> WX.propagateEvent
    WX.KeyChar '9' -> WX.propagateEvent
    WX.KeyChar '.' -> when (not (elem '.' text) && lastCharIsDigit) 
                        WX.propagateEvent
    WX.KeyChar '-' -> when (null text) WX.propagateEvent
    WX.KeyChar _ -> return ()
    WX.KeySpace -> return ()
    _ -> WX.propagateEvent

okLabel :: String
okLabel = __ "&Ok"

okButton :: b -> Layout a b
okButton = Widget . DefaultButton okLabel

cancelButton :: Layout a b
cancelButton = Widget $ TerminationButton (__ "&Cancel")