Manager.hs

-- -*-haskell-*-
--  Vision (for the Voice): an XMMS2 client.
--
--  Author:  Oleg Belozeorov
--  Created: 5 Jul. 2010
--
--  Copyright (C) 2010, 2011 Oleg Belozeorov
--
--  This program is free software; you can redistribute it and/or
--  modify it under the terms of the GNU General Public License as
--  published by the Free Software Foundation; either version 3 of
--  the License, or (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
--  General Public License for more details.
--

{-# LANGUAGE TupleSections #-}

module Properties.Manager
  ( initPropertyManager
  , showPropertyManager
  ) where

import Control.Applicative
import Control.Monad

import Data.IORef
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Ord
import Data.Char

import System.IO.Unsafe

import Graphics.UI.Gtk

import Utils
import Compound
import Context
import UI
import Editor
import Properties.Property
import Properties.Model


data Manager
  = Manager { pManager :: EditorDialog PropertyManager }

manager = pManager context


initPropertyManager = do
  manager <- unsafeInterleaveIO $ makeEditorDialog
             [(stockApply, ResponseApply)]
             makePropertyManager $ \m -> do
    let outerw = outer m
    windowSetTitle outerw "Manage properties"
    windowSetDefaultSize outerw 500 400
  return $ augmentContext
    Manager { pManager = manager }

showPropertyManager =
  runEditorDialog manager getProperties setProperties False window


data PropertyManager
  = PropertyManager { pStore   :: ListStore Property
                    , pView    :: TreeView
                    , pBox     :: VBox
                    , pChanged :: IORef Bool
                    , pNames   :: IORef (Set String)
                    }

instance CompoundWidget PropertyManager where
  type Outer PropertyManager = VBox
  outer = pBox

instance EditorWidget PropertyManager where
  type Data PropertyManager = [Property]
  getData       = propertyManagerGetData
  setData       = propertyManagerSetData
  clearData     = propertyManagerClearData
  setupView     = propertyManagerSetupView
  focusView     = propertyManagerFocusView
  getState      = propertyManagerGetState
  resetModified = propertyManagerResetModified

propertyManagerGetData =
  listStoreToList . pStore

propertyManagerSetData pm props = do
  let store = pStore pm
  listStoreClear store
  writeIORef (pNames pm) =<<
    foldM (\names prop -> do
              listStoreAppend store prop
              return $ Set.insert (propName prop) names
          ) Set.empty props

propertyManagerClearData pm = do
  listStoreClear $ pStore pm
  writeIORef (pNames pm) Set.empty

propertyManagerSetupView pm =
  treeViewSetCursor (pView pm) [0] Nothing

propertyManagerFocusView =
  widgetGrabFocus . pView

propertyManagerGetState =
  liftM (True, ) . readIORef . pChanged

propertyManagerResetModified =
  flip writeIORef False . pChanged

makePropertyManager parent notify = do
  names <- newIORef Set.empty

  store  <- listStoreNewDND [] Nothing Nothing
  sorted <- treeModelSortNewWithModel store

  let getByIter iter = do
        [n] <- treeModelGetPath store iter
        listStoreGetValue store n
      compBy :: Ord a => (Property -> a) -> TreeIter -> TreeIter -> IO Ordering
      compBy f a b =
        comparing f <$> getByIter a <*> getByIter b

  treeSortableSetDefaultSortFunc sorted $ Just $ compBy (map toLower . propName)
  treeSortableSetSortFunc sorted 0 $ compBy (map toLower . propName)
  treeSortableSetSortFunc sorted 1 $ compBy (map toLower . propKey)
  treeSortableSetSortFunc sorted 2 $ compBy (fromEnum . propType)
  treeSortableSetSortFunc sorted 3 $ compBy (fromEnum . propReadOnly)
  treeSortableSetSortFunc sorted 4 $ compBy (fromEnum . propCustom)

  view <- treeViewNewWithModel sorted
  treeViewSetRulesHint view True

  let showType p =
        case propType p of
          PropertyInt    -> "integer"
          PropertyString -> "string"
      showBool acc p =
        if acc p then "yes" else "no"
      addColumn title id acc = do
        column <- treeViewColumnNew
        treeViewColumnSetSortColumnId column id
        treeViewAppendColumn view column
        treeViewColumnSetTitle column title
        cell <- cellRendererTextNew
        treeViewColumnPackStart column cell True
        cellLayoutSetAttributes column cell store
          (\p -> [ cellText := acc p ])

  addColumn "Name"      0   propName
  addColumn "Key"       1   propKey
  addColumn "Type"      2   showType
  addColumn "Read-only" 3 $ showBool propReadOnly
  addColumn "Custom"    4 $ showBool propCustom

  scroll <- scrolledWindowNew Nothing Nothing
  scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic
  scrolledWindowSetShadowType scroll ShadowIn
  containerAdd scroll view

  changed <- newIORef False

  let setChanged = do
        writeIORef changed True
        notify
      addProperty prop = do
        listStoreAppend store prop
        modifyIORef names $ Set.insert (propName prop)
        setChanged
        return ()
      exists name = Set.member name <$> readIORef names

  edlg <- unsafeInterleaveIO $ makeEditorDialog []
          (makePropertyEntry exists) (const $ return ())
  addB <- buttonNewFromStock stockAdd
  addB `onClicked`
    runEditorDialog edlg (return nullProperty) addProperty True parent

  delB <- buttonNewFromStock stockRemove
  delB `onClicked` do
    (path, _) <- treeViewGetCursor view
    case path of
      [n] -> do
        [n'] <- treeModelSortConvertPathToChildPath sorted path
        prop <- listStoreGetValue store n'
        when (propCustom prop) $ do
          listStoreRemove store n'
          modifyIORef names $ Set.delete (propName prop)
          s <- listStoreGetSize store
          unless (s < 1) $
            treeViewSetCursor view [min (s - 1) n] Nothing
          setChanged
      _ ->
        return ()

  view `on` cursorChanged $ do
    (path, _) <- treeViewGetCursor view
    case path of
      [_] -> do
        [n'] <- treeModelSortConvertPathToChildPath sorted path
        prop <- listStoreGetValue store n'
        widgetSetSensitive delB $ propCustom prop
      _ ->
        widgetSetSensitive delB False

  bbox <- hBoxNew True 5
  boxPackStartDefaults bbox addB
  boxPackStartDefaults bbox delB

  vbox <- vBoxNew False 5
  containerSetBorderWidth vbox 7
  boxPackStart vbox scroll PackGrow 0
  boxPackStart vbox bbox PackNatural 0

  return PropertyManager { pStore   = store
                         , pView    = view
                         , pBox     = vbox
                         , pChanged = changed
                         , pNames   = names
                         }


data PropertyEntry
  = PropertyEntry
    { eTable  :: Table
    , eName   :: Entry
    , eKey    :: Entry
    , eType   :: ComboBox
    , eRO     :: ComboBox
    , eExists :: String -> IO Bool
    }

instance CompoundWidget PropertyEntry where
  type Outer PropertyEntry = Table
  outer = eTable

instance EditorWidget PropertyEntry where
  type Data PropertyEntry = Property
  setData       = propertyEntrySetData
  getData       = propertyEntryGetData
  focusView     = propertyEntryFocusView
  getState      = propertyEntryGetState
  resetModified = const $ return ()

propertyEntrySetData e p = do
  entrySetText (eName e) (propName p)
  entrySetText (eKey e) (propKey p)
  comboSet (eType e) Nothing (propType p)
  comboSet (eRO e) Nothing (propReadOnly p)

propertyEntryGetData e = do
  pname  <- entryGetText $ eName e
  pkey   <- entryGetText $ eKey e
  ptype  <- comboGet $ eType e
  pro    <- comboGet $ eRO e
  return Property { propName      = trim pname
                  , propKey       = trim pkey
                  , propType      = ptype
                  , propReadOnly  = pro
                  , propCustom    = True
                  , propReadValue = Nothing
                  , propShowValue = Nothing
                  }

propertyEntryFocusView =
  widgetGrabFocus . eName

propertyEntryGetState e = do
  name <- trim <$> entryGetText (eName e)
  key  <- trim <$> entryGetText (eKey e)
  (, True) <$> propertyEntryValid (eExists e) name key

propertyEntryValid exists name key = do
  e <- exists name
  return . not $ e || null name || null key

makePropertyEntry exists _ notify = do
  table <- tableNew 4 2 False
  containerSetBorderWidth table 7
  tableSetColSpacings table 15
  tableSetRowSpacings table 5

  let addPair :: WidgetClass w => String -> w -> Int -> IO ()
      addPair m w b = do
        l <- labelNewWithMnemonic m
        miscSetAlignment l 0.0 0.5
        labelSetMnemonicWidget l w
        tableAttach table l 0 1 b (b + 1) [Fill] [] 0 0
        tableAttach table w 1 2 b (b + 1) [Expand, Fill] [] 0 0

  nameE <- entryNew
  addPair "_Name" nameE 0

  keyE <- entryNew
  addPair "_Key" keyE 1

  typeC <- comboBoxNewText
  comboBoxInsertText typeC (fromEnum PropertyString) "string"
  comboBoxInsertText typeC (fromEnum PropertyInt) "integer"
  typeRef <- newIORef PropertyString
  typeCid <- setupCombo typeC typeRef
  addPair "_Type" typeC 2

  roC <- comboBoxNewText
  comboBoxInsertText roC (fromEnum False) "no"
  comboBoxInsertText roC (fromEnum True) "yes"
  roRef <- newIORef False
  roCid <- setupCombo roC roRef
  addPair "_Read-only" roC 3

  let check = do
        notify
        key <- trim <$> entryGetText keyE
        case Map.lookup key builtinPropertyMap of
          Just prop -> do
            comboSet typeC (Just typeCid) $ propType prop
            widgetSetSensitive typeC False
            comboSet roC (Just roCid) $ propReadOnly prop
            widgetSetSensitive roC False
          Nothing   -> do
            comboSet typeC (Just typeCid) =<< readIORef typeRef
            widgetSetSensitive typeC True
            comboSet roC (Just roCid) =<< readIORef roRef
            widgetSetSensitive roC True

      checkInsert str pos = do
        check
        return $ length str + pos

      checkDelete _ _ = check

  nameE `afterInsertText` checkInsert
  nameE `afterDeleteText` checkDelete
  keyE  `afterInsertText` checkInsert
  keyE  `afterDeleteText` checkDelete

  return PropertyEntry { eTable  = table
                       , eName   = nameE
                       , eKey    = keyE
                       , eType   = typeC
                       , eRO     = roC
                       , eExists = exists
                       }


nullProperty =
  Property { propName      = ""
           , propKey       = ""
           , propType      = PropertyString
           , propReadOnly  = False
           , propCustom    = True
           , propReadValue = Nothing
           , propShowValue = Nothing
           }


comboGet combo =
  toEnum <$> comboBoxGetActive combo

comboSet ::
  Enum a                     =>
  ComboBox                   ->
  Maybe (ConnectId ComboBox) ->
  a                          ->
  IO ()
comboSet combo cid =
  maybe id withSignalBlocked cid . comboBoxSetActive combo . fromEnum

setupCombo combo ref =
  combo `on` changed $ (writeIORef ref =<< comboGet combo)