{-# Language TypeFamilies, DeriveDataTypeable #-}

-----------------------------------------------------------------------------
--
-- Module      :  Graphics.Menu
-- Copyright   :  Juergen Nicklisch-Franken
-- License     :  LGPL
--
-- Maintainer  :  maintainer@leksah.org
-- Stability   :  provisional
-- Portability :  portabel
--
-- | Menu services
--
-----------------------------------------------------------------------------

module Graphics.Menu (
    initActions,
    setSensitivity,
    registerActionState,
    initialActionState,

    toggleToolbar,
    showToolbar,
    toolbarVisible
)where

import Base
import Graphics.FrameTypes
import Graphics.Frame
import Graphics.Panes
import Graphics.Statusbar


import Data.Version (Version(..))
import Data.Typeable (Typeable)
import Control.Monad.IO.Class (MonadIO(..))
import Graphics.UI.Gtk
import Control.Monad (liftM, when, foldM_, filterM, foldM)
import Data.List (nub, elemIndex)
import Data.Map (Map)
import qualified Data.Map as Map (fromList, lookup, empty)
import Data.Maybe (fromJust, mapMaybe, catMaybes)



-----------------------------------------
-- * The handling of the state of the frame
--
type ActionState = Map GenSelector [String]

data ActionStateSel = ActionStateSel
    deriving (Eq, Ord, Show, Typeable)

instance Selector ActionStateSel where
    type ValueType ActionStateSel = ActionState

registerActionState :: ActionState -> StateM (Maybe String)
registerActionState = registerState ActionStateSel

setActionState :: ActionState -> StateM ()
setActionState    st  = do
    message Debug ("setActionState: " ++ show st)
    setState ActionStateSel st

getActionState :: StateM (ActionState)
getActionState      = getState ActionStateSel

initialActionState = Map.empty

--------------------------------------------------------------
-- * Actions

--
-- | * Builds the menu and toolbar from the action description,
--     and registers accelerators from the action descriptions
initActions :: UIManager -> [ActionDescr] -> StateM (MenuBar,Toolbar)
initActions uiManager actionDescrs = do
    message Debug "initAction"
    mb           <- liftIO $ menuBarNew
    tb           <- liftIO $ toolbarNew
    actionGroup  <- liftIO $ actionGroupNew "global"
    accGroup     <- liftIO $ uiManagerGetAccelGroup uiManager
    foldM_ (buildAction uiManager accGroup actionGroup tb mb) (Nothing,Nothing) actionDescrs
    liftIO $ uiManagerInsertActionGroup uiManager actionGroup 1
    setActionState (buildActionState actionDescrs)
    return (mb,tb)


buildActionState :: [ActionDescr] -> Map GenSelector [String]
buildActionState actionDescrs = Map.fromList $ zip allSensitivities (map actionStringsFor allSensitivities)
  where
    allSensitivities = nub $ concatMap adSensitivities actionDescrs
    actionStringsFor sens = mapMaybe (actionStringFor sens) actionDescrs
    actionStringFor sens AD{adName = name, adSensitivities = sensitivities}
        | elem sens sensitivities = Just name
        | otherwise               = Nothing

buildAction uiManager accGroup actionGroup toolBar mb lastPosition actionDescr =
    let (acc,accString) = case adAccelerator actionDescr of
                               Nothing ->  (Nothing,"=" ++ adName actionDescr)
                               Just ha ->  (Just ha, ha ++ "=" ++ adName actionDescr)
    in case adActionType actionDescr of
        ActionSubmenu -> reifyState $ \ stateR -> do
            fst <- buildMenuItem uiManager mb (Nothing :: Maybe Action)
                        actionDescr (fst lastPosition)
            return (fst, snd lastPosition)
        ActionNormal -> reifyState $ \ stateR -> do
            act <- actionNew (adName actionDescr)
                (adLabel actionDescr) (adSynopsis actionDescr) (adStockID actionDescr)
            actionSetAccelGroup act accGroup
            onActionActivate act (reflectState (do
                adAction actionDescr
                setStatusText "SBActions" accString) stateR)
            actionGroupAddActionWithAccel actionGroup act acc
            fst <- buildMenuItem uiManager mb (Just act) actionDescr (fst lastPosition)
            snd <- buildToolItem uiManager toolBar (Just act) actionDescr (snd lastPosition)
            return (fst,snd)
        ActionToggle -> reifyState $ \ stateR -> do
            act <- toggleActionNew (adName actionDescr)
                (adLabel actionDescr) (adSynopsis actionDescr) (adStockID actionDescr)
            actionSetAccelGroup act accGroup
            on act actionToggled (reflectState (do
                adAction actionDescr
                setStatusText "SBActions" accString) stateR)
            actionGroupAddActionWithAccel actionGroup act acc
            fst <- buildMenuItem uiManager mb (Just act) actionDescr (fst lastPosition)
            snd <- buildToolItem uiManager toolBar (Just act) actionDescr (snd lastPosition)
            return (fst,snd)

--------------------------------------------------------------
-- * Menus

buildMenuItem :: ActionClass alpha => UIManager -> MenuBar -> Maybe alpha -> ActionDescr
                    -> Maybe (MenuShell,Int) -> IO (Maybe (MenuShell,Int))
buildMenuItem uiManager mb mbAction ad@AD{adMenu = menuPos, adName = name} mbLast
    | menuPos == Nothing = case adAccelerator ad of
                            Nothing -> return mbLast
                            Just str -> do
                                uiManagerAddUiFromString uiManager $
                                    "<accelerator name=\"" ++ name
                                        ++ "\" action=\"" ++ name  ++ "\"/>"
                                return mbLast
    | otherwise        = do
        menuItem <- mkMenuItem mbAction ad
        res <- getInsertion (castToMenuShell mb) (fromJust menuPos)
        case res of
            Nothing -> error ("Menu>>buildMenuItem: No valid position for: " ++ adName ad)
            Just (Prepend ms) -> do
                menuShellPrepend ms (castToMenuItem menuItem)
                return (Just (ms,0))
            Just (Append ms separated) -> do
                when separated $ do
                    sep <- separatorMenuItemNew
                    menuShellAppend ms sep
                menuShellAppend ms (castToMenuItem menuItem)
                idx <- getMenuIndexForItem ms (castToMenuItem menuItem)
                case idx of
                    Nothing -> return (Just (ms,0))
                    Just idx -> return (Just (ms,idx))
            Just (Insert idx ms separated) -> do
                idx' <-  if separated
                                then do
                                    sep <- separatorMenuItemNew
                                    menuShellInsert ms sep idx
                                    return (idx + 1)
                                else return idx
                menuShellInsert ms (castToMenuItem menuItem) idx'
                return (Just (ms,idx'))
            Just (AfterLast separated) -> do
                case mbLast of
                    Nothing -> error ("Menu>>buildMenuItem: No last insertion for: " ++ adName ad)
                    Just (ms,idx) -> do
                        idx' <-  if separated
                                then do
                                    sep <- separatorMenuItemNew
                                    menuShellInsert ms sep (idx + 1)
                                    return (idx + 1)
                                else return idx
                        menuShellInsert ms (castToMenuItem menuItem) (idx' + 1)
                        return (Just (ms,idx' + 1))

mkMenuItem :: ActionClass alpha => Maybe alpha -> ActionDescr -> IO MenuItem
mkMenuItem Nothing AD{adActionType = actionType, adLabel = label}
    | actionType == ActionSubmenu = do
        menuItem <- menuItemNewWithMnemonic label
        subMenu <- menuNew
        menuItemSetSubmenu menuItem subMenu
        return menuItem
    | otherwise = error "Menu>>mkMenuItem: Impossible"
mkMenuItem (Just action) AD{adActionType = actionType}
    | actionType == ActionNormal || actionType == ActionToggle  = do
        menuItem <- actionCreateMenuItem action
        return (castToMenuItem menuItem)
data MenuPos = Prepend MenuShell  | Append MenuShell Bool  | Insert Int MenuShell Bool
                | AfterLast Bool

getInsertion :: MenuShell ->  MenuPosition -> IO (Maybe MenuPos)
getInsertion mb (MPFirst path)      = do
                                        res <- getMenuShellForPath path mb
                                        case res of
                                            Nothing -> return Nothing
                                            Just ms -> return (Just (Prepend ms))
getInsertion mb (MPLast path sep)   = do
                                        res <- getMenuShellForPath path mb
                                        case res of
                                            Nothing -> return Nothing
                                            Just ms -> return (Just (Append ms sep))
getInsertion mb (MPAfter [] sep)    = error "Menu>>getInsertion: Empty After path"
getInsertion mb (MPAfter (name:path) sep)
                                    = do
                                        res <- getMenuShellForPath path mb
                                        case res of
                                            Nothing -> return Nothing
                                            Just ms -> do
                                                mbIdx <- getMenuIndexForName ms name
                                                case mbIdx of
                                                    Nothing -> return Nothing
                                                    Just idx -> return
                                                        (Just (Insert (idx + 1)
                                                            ms sep))
getInsertion mb (MPBefore [])       = error "Menu>>getInsertion: Empty Before path"
getInsertion mb (MPBefore (n:p))    = do
                                        res <- getMenuShellForPath p mb
                                        case res of
                                            Nothing -> return Nothing
                                            Just ms -> do
                                                mbIdx <- getMenuIndexForName ms n
                                                case mbIdx of
                                                    Nothing -> return Nothing
                                                    Just idx -> return
                                                        (Just (Insert idx ms False))
getInsertion mb (MPAppend sep)      = return (Just (AfterLast sep))
getInsertion mb (MPOr mp1 mp2)      = do
                                        mbFirst <- getInsertion mb mp1
                                        case mbFirst of
                                            Just t -> return (Just t)
                                            Nothing -> getInsertion mb mp2

getMenuShellForPath :: [String] -> MenuShell -> IO (Maybe MenuShell)
getMenuShellForPath [] menu        = return (Just menu)
getMenuShellForPath (hd:rest) menu = do
    widgets <- containerGetChildren menu
    res <- filterM (\ w -> do
                            mbLabel <- binGetChild (castToBin w)
                            case mbLabel of
                                Nothing -> return False
                                Just label -> do
                                        n <- labelGetText (castToLabel label)
                                        return (n == hd)) widgets
    case res of
        [w]        -> do
            submenu <- menuItemGetSubmenu (castToMenuItem w)
            case submenu of
                Nothing -> error ("Menu>>getMenuShellForPath: Can't find submenu for " ++ hd)
                Just w  -> getMenuShellForPath rest (castToMenuShell w)
        otherwise  -> return Nothing

getMenuIndexForName :: MenuShell  -> String -> IO (Maybe Int)
getMenuIndexForName menu name = do
    widgets <- containerGetChildren menu
    res <- filterM (\ (w,_) -> do
                            mbLabel <- binGetChild (castToBin w)
                            case mbLabel of
                                Nothing -> return False
                                Just label -> do
                                        n <- labelGetText (castToLabel label)
                                        return (n == name))
                    (zip widgets [0..])
    case res of
        [(w,idx)]  -> return (Just idx)
        otherwise  -> return Nothing

getMenuIndexForItem :: MenuShell  -> MenuItem -> IO (Maybe Int)
getMenuIndexForItem menu item = do
    widgets <- containerGetChildren menu
    return (elemIndex item (map castToMenuItem widgets))

--------------------------------------------------------------
-- * Toolbar

buildToolItem :: ActionClass alpha => UIManager -> Toolbar -> Maybe alpha -> ActionDescr
                    -> Maybe Int -> IO (Maybe Int)
buildToolItem uiManager tb Nothing ad@AD{adToolbar = toolPos, adName = name} mbLast
                     = return mbLast
buildToolItem uiManager tb (Just action) ad@AD{adToolbar = toolPos, adName = name} mbLast
    | toolPos == Nothing = return mbLast
    | otherwise      = do
        toolItem <- liftM castToToolItem (actionCreateToolItem action)
        res <- getToolInsertion tb (fromJust toolPos)
        case res of
            Nothing -> error ("Menu>>buildToolItem: No valid position for: " ++ adName ad)
            Just (InsertTool ind True) -> do
                        sep <- separatorToolItemNew
                        toolbarInsert tb sep ind
                        toolbarInsert tb toolItem (ind + 1)
                        return (Just (ind + 2))
            Just (InsertTool ind False) -> do
                        toolbarInsert tb toolItem ind
                        return (Just (ind + 1))
            Just (AfterLastTool True) -> do
                        case mbLast of
                            Nothing ->  error $ "Menu>>buildToolItem: No last insertion for: "
                                                    ++ adName ad
                            Just ind -> do
                                toolbarInsert tb toolItem ind
                                return (Just (ind + 1))
            Just (AfterLastTool False) -> do
                        case mbLast of
                            Nothing ->  error $ "Menu>>buildToolItem: No last insertion for: "
                                                    ++ adName ad
                            Just ind -> do
                                sep <- separatorToolItemNew
                                toolbarInsert tb sep ind
                                toolbarInsert tb toolItem (ind + 1)
                                return (Just (ind + 2))



data ToolPos = InsertTool Int Bool | AfterLastTool Bool


getToolInsertion :: Toolbar ->  ToolPosition -> IO (Maybe ToolPos)
getToolInsertion tb TPFirst             = return $ Just (InsertTool 0 False)
getToolInsertion tb (TPLast sep)        = do
                                            n <- toolbarGetNItems tb
                                            return $ Just (InsertTool n sep)
getToolInsertion tb (TPAfter str sep)   = do
                                            mbIndex <- getToolIndexForName tb str
                                            case mbIndex of
                                                Just ind -> return $ Just (InsertTool (ind +1) sep)
                                                Nothing -> return $ Nothing
getToolInsertion tb (TPBefore str)      = do
                                            mbIndex <- getToolIndexForName tb str
                                            case mbIndex of
                                                Just ind -> return $ Just
                                                    (InsertTool ind False)
                                                Nothing -> return $ Nothing
getToolInsertion tb (TPAppend sep)      = return $ Just (AfterLastTool sep)
getToolInsertion tb (TPOr mp1 mp2)      = do
                                            mbFirst <- getToolInsertion tb mp1
                                            case mbFirst of
                                                Just t -> return (Just t)
                                                Nothing -> getToolInsertion tb mp2


getToolIndexForName :: Toolbar -> String -> IO (Maybe Int)
getToolIndexForName tb name = do
    widgets <- containerGetChildren tb
    res <- filterM (\ (w,_) -> do
                            mbString <- get  (castToToolButton w) toolButtonLabel
                            case mbString of
                                Nothing -> return False
                                Just string -> do
                                        return (string == name))
                    (zip widgets [0..])
    case res of
        [(w,idx)]  -> return (Just idx)
        otherwise  -> return Nothing

toggleToolbar :: StateM ()
toggleToolbar = do
    mbToolbar <-  getToolbar
    tbv       <-  toolbarVisible
    case mbToolbar of
        Nothing -> return ()
        Just tb -> if tbv
                    then liftIO $ widgetShowAll tb
                    else liftIO $ widgetHideAll tb

showToolbar :: Bool -> StateM ()
showToolbar showIt = do
    mbToolbar <-  getToolbar
    uiManager <- getUiManagerSt
    case mbToolbar of
        Nothing -> return ()
        Just tb -> if showIt
                        then liftIO $ widgetShowAll tb
                        else liftIO $ widgetHideAll tb
    mbAct <- liftIO $ getActionFor uiManager "ToolbarVisible"
    case mbAct of
        Nothing -> return ()
        Just act -> liftIO $ toggleActionSetActive (castToToggleAction act) showIt

toolbarVisible :: StateM Bool
toolbarVisible = do
    uiManager <- getUiManagerSt
    mbAct <- liftIO $ getActionFor uiManager "ToolbarVisible"
    case mbAct of
        Nothing -> return False
        Just act -> liftIO $ toggleActionGetActive (castToToggleAction act)

--------------------------------------------------------------
-- * Sensitivity

--
-- | Setting sensivity
--
setSensitivity :: Selector s => [(s, Bool)] -> StateM ()
setSensitivity l = do
    message Debug ("setSensitivity " ++ show l)
    mapM_ setSensitivitySingle l
    message Debug ("after setSensitivity" ++ show l)
  where
    setSensitivitySingle (sens,bool) = do
        actions <- getActionsFor sens
        liftIO $ mapM_ (\a -> actionSetSensitive a bool) actions

getActionsFor :: Selector s => s -> StateM [Action]
getActionsFor sens = do
    actMap <-  getActionState
    uiManager <- getUiManagerSt
    case Map.lookup (GS sens) actMap of
        Nothing -> return []
        Just l -> do
            maybeList <- liftIO $ (mapM (getActionFor uiManager) l)
            return (catMaybes maybeList)

getActionFor uiManager string = do
    actionGroups <- uiManagerGetActionGroups uiManager
    actionGroupGetAction (head actionGroups) string