{-# OPTIONS_GHC  #-}
-----------------------------------------------------------------------------
--
-- Module      :  IDE.Core.ViewFrame
-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License     :  GNU-GPL
--
-- Maintainer  :  Juergen Nicklisch-Franken <info at leksah.org>
-- Stability   :  experimental
-- Portability :  portable
--
--
-- | Splittable panes containing notebooks with any widgets
--
---------------------------------------------------------------------------------

module Graphics.UI.Frame.ViewFrame (
    removePaneAdmin
,   addPaneAdmin
,   notebookInsertOrdered

-- * Convenience methods for accesing Pane state
,   posTypeToPaneDirection
,   paneDirectionToPosType
,   paneFromName
,   mbPaneFromName
,   guiPropertiesFromName

-- * View Actions
,   viewMove
,   viewSplitHorizontal
,   viewSplitVertical
,   viewSplit
,   viewSplit'
,   handleNotebookSwitch
,   viewCollapse
,   viewCollapse'
,   viewTabsPos
,   viewSwitchTabs

-- * View Queries
,   getStandardPanePath
,   getActivePanePath
,   getActivePanePathOrStandard
,   figureOutPaneName
,   getNotebook
,   getPaned
,   getActiveNotebook
,   getPane
,   getPanes

-- * View Actions
,   bringPaneToFront
,   newNotebook

-- * Accessing GUI elements
,   widgetFromPath
,   getUIAction
,   widgetGet


) where

import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite)
import Control.Monad.Reader
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List
import Data.Maybe
#if __GLASGOW_HASKELL__ >= 609
import Control.OldException(evaluate,catch)
#else
import Control.Exception(evaluate,catch)
#endif
import Prelude hiding(catch)
import Data.Unique
import Data.Typeable

import Graphics.UI.Frame.Panes
import Graphics.UI.Editor.Parameters

removePaneAdmin :: Pane alpha beta => alpha -> beta ()
removePaneAdmin pane = do
    panes'          <-  getPanesSt
    paneMap'        <-  getPaneMapSt
    setPanesSt      (Map.delete (paneName pane) panes')
    setPaneMapSt    (Map.delete (paneName pane) paneMap')

addPaneAdmin :: RecoverablePane alpha beta delta => alpha -> Connections -> PanePath -> delta ()
addPaneAdmin pane conn pp = do
    panes'          <-  getPanesSt
    paneMap'        <-  getPaneMapSt
    unique          <-  liftIO newUnique
    liftIO $ widgetSetName (getTopWidget pane) (show (hashUnique unique))
    setPaneMapSt        (Map.insert (paneName pane) (pp, conn) paneMap')
    setPanesSt          (Map.insert (paneName pane) (PaneC pane) panes')

getPane ::  RecoverablePane alpha beta delta => delta (Maybe alpha)
getPane = do
    selectedPanes <- getPanes
    if null selectedPanes || length selectedPanes > 1
        then return Nothing
        else (return (Just $head selectedPanes))

getPanes ::  RecoverablePane alpha beta delta => delta ([alpha])
getPanes = do
    panes' <- getPanesSt
    return (catMaybes
                $ map (\(PaneC p) -> cast p)
                    $ Map.elems panes')

notebookInsertOrdered :: (NotebookClass self, WidgetClass child)		
    => self	
    -> child	-- child - the Widget to use as the contents of the page.
    -> String	-- tabLabel - the label for the page
    -> Maybe Label
    -> IO ()
notebookInsertOrdered nb widget label mbTabLabel = do
    menuLabel   <-  labelNew (Just label)
    tabLabel    <-  case mbTabLabel of
                        Nothing -> labelNew (Just label)
                        Just l  -> return l
    numPages    <-  notebookGetNPages nb
    mbWidgets   <-  mapM (notebookGetNthPage nb) [0 .. (numPages-1)]
    widgets     <-  catch (evaluate (map fromJust mbWidgets))
                        (\e -> error "ViewFrame.notebookInsertOrdered: no widget")
    mbLabels    <-  mapM (notebookGetTabLabelText nb) widgets
    labels      <-  catch (evaluate (map fromJust mbLabels))
                        (\e -> error "ViewFrame.notebookInsertOrdered: no label")
    let pos     =   case findIndex (\s -> s > label) labels of
                        Just i  ->  i
                        Nothing ->  -1
    realPos     <-  notebookInsertPageMenu nb widget tabLabel menuLabel pos
    notebookSetCurrentPage nb realPos



-- | Constructs a unique pane name, which is an index and a string
figureOutPaneName :: Map String (IDEPane alpha) -> String -> Int -> (Int,String)
figureOutPaneName bufs bn ind =
    let ind = foldr (\(PaneC buf) ind ->
                if primPaneName buf == bn
                    then max ind ((getAddedIndex buf) + 1)
                    else ind)
                0 (Map.elems bufs)
    in  if ind == 0
            then (0,bn)
            else (ind,bn ++ "(" ++ show ind ++ ")")

paneFromName :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha)
paneFromName pn = do
    mbPane <- mbPaneFromName pn
    case mbPane of
        Just p -> return p
        Nothing -> error $"Cant't find pane from unique name " ++ pn

mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha))
mbPaneFromName pn = do
    panes  <- getPanesSt
    return (Map.lookup pn panes)

-- |
guiPropertiesFromName :: PaneMonad alpha => PaneName -> alpha (PanePath, Connections)
guiPropertiesFromName pn = do
    paneMap <- getPaneMapSt
    case Map.lookup pn paneMap of
            Just it -> return it
            otherwise  -> error $"Cant't find guiProperties from unique name " ++ pn

posTypeToPaneDirection PosLeft      =   LeftP
posTypeToPaneDirection PosRight     =   RightP	
posTypeToPaneDirection PosTop       =   TopP
posTypeToPaneDirection PosBottom    =   BottomP	

paneDirectionToPosType LeftP        =   PosLeft
paneDirectionToPosType RightP       =   PosRight   	
paneDirectionToPosType TopP         =   PosTop
paneDirectionToPosType BottomP      =   PosBottom

--
-- | Toggle the tabs of the current notebook
--
viewSwitchTabs :: PaneMonad alpha => alpha ()
viewSwitchTabs = do
    mbNb <- getActiveNotebook
    case mbNb of
        Nothing -> return ()
        Just nb -> liftIO $do
            b <- notebookGetShowTabs nb
            notebookSetShowTabs nb (not b)

--
-- | Sets the tab position in the current notebook
--
viewTabsPos :: PaneMonad alpha => PositionType -> alpha ()
viewTabsPos pos = do
    mbNb <- getActiveNotebook
    case mbNb of
        Nothing -> return ()
        Just nb -> liftIO $notebookSetTabPos nb pos

--
-- | Split the currently active pane in horizontal direction
--
viewSplitHorizontal     :: PaneMonad alpha => alpha ()
viewSplitHorizontal     = viewSplit Horizontal

--
-- | Split the currently active pane in vertical direction
--
viewSplitVertical :: PaneMonad alpha => alpha ()
viewSplitVertical = viewSplit Vertical

--
-- | The active view can be split in two (horizontal or vertical)
--
viewSplit :: PaneMonad alpha => Direction -> alpha ()
viewSplit dir = do
    mbPanePath <- getActivePanePath
    case mbPanePath of
        Nothing -> return ()
        Just panePath -> viewSplit' panePath dir

viewSplit' :: PaneMonad alpha => PanePath -> Direction -> alpha ()
viewSplit' panePath dir = do
    activeNotebook  <- getNotebook panePath

    mbPD <- do
      mbParent  <- liftIO $ widgetGetParent activeNotebook
      case mbParent of
          Nothing -> return Nothing
          Just parent -> do
              (nb,paneDir) <- liftIO $ do
                  --trace ("Pane path " ++ show panePath) return ()
                  newpane <- case dir of
                                  Horizontal  -> do  h <- vPanedNew
                                                     return (castToPaned h)
                                  Vertical    -> do  v <- hPanedNew
                                                     return (castToPaned v)
                  let (name,altname,paneDir) = case dir of
                              Horizontal  -> ("top","bottom",TopP)
                              Vertical    -> ("left","right",LeftP)
                  rName <- widgetGetName activeNotebook
                  widgetSetName newpane rName
                  nb <- newNotebook
                  widgetSetName nb altname
                  panedPack2 newpane nb True True
                  containerRemove (castToContainer parent) activeNotebook
                  widgetSetName activeNotebook name
                  panedPack1 newpane activeNotebook True True
                  if not (null panePath)
                      then
                          if (last panePath == TopP || last panePath == LeftP)
                              then  panedPack1 (castToPaned parent) newpane True True
                              else  panedPack2 (castToPaned parent) newpane True True
                      else do
                          boxPackStart (castToBox parent) newpane PackGrow 0
                          boxReorderChild (castToVBox parent) newpane 2
                  widgetShowAll newpane
                  widgetGrabFocus activeNotebook
                  return (nb,paneDir)
              handleFunc <-  runInIO (handleNotebookSwitch nb)
              liftIO $ afterSwitchPage nb handleFunc
              return (Just (paneDir,dir))
    case mbPD of
      Just (paneDir,dir) -> do
          let toPane = panePath ++ [paneDir]
          adjustPane panePath toPane
          adjustLayoutForSplit dir panePath
      Nothing -> return ()

handleNotebookSwitch :: PaneMonad beta => Notebook -> Int -> beta ()
handleNotebookSwitch nb index = do
    mbW <- liftIO $ notebookGetNthPage nb index
    case mbW of
        Nothing -> error "ViewFrame/handleNotebookSwitch: Can't find widget"
        Just w  -> do
            mbPane <- findPaneFor w
            case mbPane of
                Nothing         ->  return ()
                Just (PaneC p)  ->  makeActive p
    where
        findPaneFor :: PaneMonad beta => Widget -> beta (Maybe (IDEPane beta))
        findPaneFor w   =   do
            panes'      <-  getPanesSt
            n1          <-  liftIO $ widgetGetName w
            foldM (\r (PaneC p) -> do
                        n2 <- liftIO $ widgetGetName (getTopWidget p)
                        return (if n1 == n2 then (Just (PaneC p)) else r))
                                Nothing (Map.elems panes')

--
-- | Two notebooks can be collapsed to one
--
viewCollapse :: PaneMonad alpha => alpha ()
viewCollapse = do
    mbPanePath        <- getActivePanePath
    case mbPanePath of
        Nothing -> return ()
        Just panePath -> do
            viewCollapse' panePath

viewCollapse' :: PaneMonad alpha => PanePath -> alpha ()
viewCollapse' panePath = do
    layout1           <- getLayoutSt
    let newPanePath   = reverse $tail $reverse panePath
    let mbOtherSidePath = otherSide panePath
    case mbOtherSidePath of
        Nothing -> return ()
        Just otherSidePath ->
            let sp1 = getSubpath panePath layout1
                sp2 = getSubpath otherSidePath layout1
            in do
            case sp1 of
                Nothing -> return ()
                Just sp -> viewCollapse' sp
            case  sp2 of
                Nothing -> return ()
                Just sp -> viewCollapse' sp
            paneMap         <- getPaneMapSt
            activeNotebook  <- getNotebook panePath
            let paneNamesToMove = map (\(w,(p,_)) -> w)
                                    $filter (\(w,(p,_)) -> p == otherSidePath)
                                        $Map.toList paneMap
            panesToMove <- mapM paneFromName paneNamesToMove
            mapM_ (\(PaneC p) -> move panePath p) panesToMove
            liftIO $ do
                mbParent <- widgetGetParent activeNotebook
                case mbParent of
                    Nothing -> error "collapse: no parent"
                    Just parent -> do
                        mbGrandparent <- widgetGetParent parent
                        case mbGrandparent of
                            Nothing -> error "collapse: no grandparent"
                            Just grandparent -> do
                                containerRemove (castToContainer grandparent) parent
                                containerRemove (castToContainer parent) activeNotebook
                                if length panePath > 1
                                    then do
                                        let dir = last newPanePath
                                        if (dir == TopP || dir == LeftP)
                                            then panedPack1 (castToPaned grandparent)
                                                    activeNotebook True True
                                            else panedPack2 (castToPaned grandparent)
                                                    activeNotebook True True
                                        widgetSetName activeNotebook $paneDirectionToWidgetName dir
                                    else do
                                        boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0
                                        boxReorderChild (castToVBox grandparent) activeNotebook 2
                                        widgetSetName activeNotebook "root"
            adjustLayoutForCollapse newPanePath
            adjustPane panePath newPanePath
                --adjustPane otherSidePath newPanePath

--
-- | Moves the given Pane to the given path
--
move ::  Pane alpha beta => PanePath -> alpha -> beta ()
move toPane idew  = do
    paneMap         <-  getPaneMapSt
    let child       =   getTopWidget idew
    (fromPane,cid)  <-  guiPropertiesFromName (paneName idew)
    fromNB          <-  getNotebook fromPane
    toNB            <-  getNotebook toPane
    liftIO $ do
        mbNum <- notebookPageNum fromNB child
        case mbNum of
            Nothing -> return ()
            Just pn -> do
                mbText <- notebookGetTabLabelText fromNB child
                mbLabel <- notebookGetTabLabel fromNB child
                case (mbText,mbLabel) of
                    (Just text, Just label) -> do
                        notebookRemovePage fromNB pn
                        notebookInsertOrdered toNB child text (Just (castToLabel label))
                    _ -> return ()
    let paneMap1    =   Map.delete (paneName idew) paneMap
    setPaneMapSt    $   Map.insert (paneName idew) (toPane,cid) paneMap1

--
-- | Moves the activePane in the given direction, if possible
-- | If their are many possibilities choose the leftmost and topmost
--
viewMove :: PaneMonad beta => PaneDirection -> beta  ()
viewMove direction = do
    mbPane <- getActivePaneSt
    case mbPane of
        Nothing -> do
            return ()
        Just (paneName,_) -> do
            (PaneC pane) <- paneFromName paneName
            mbPanePath <- getActivePanePath
            case mbPanePath of
                Nothing -> do
                    return ()
                Just panePath -> do
                  layout <- getLayoutSt
                  case findMoveTarget panePath layout direction of
                      Nothing -> do
                        return ()
                      Just moveTo -> move moveTo pane

--
-- | Find the target for a move
--
findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath
findMoveTarget panePath layout direction=
    let reversedPath    = reverse panePath
        oppositeDir     = otherDirection direction
        cutPath         = dropWhile (\d -> d /= oppositeDir) reversedPath
    in if null cutPath
        then Nothing
        else let basePath = reverse (direction : tail cutPath)
                 layoutP  = layoutFromPath basePath layout
             in  Just $basePath ++ findAppropriate layoutP oppositeDir

findAppropriate :: PaneLayout -> PaneDirection -> PanePath
findAppropriate  (TerminalP _ _) _ =   []
findAppropriate  (HorizontalP t b _) LeftP     =   TopP    :  findAppropriate t LeftP
findAppropriate  (HorizontalP t b _) RightP    =   TopP    :  findAppropriate t RightP
findAppropriate  (HorizontalP t b _) BottomP   =   BottomP :  findAppropriate b BottomP
findAppropriate  (HorizontalP t b _) TopP      =   TopP    :  findAppropriate b TopP
findAppropriate  (VerticalP l r _) LeftP       =   LeftP   :  findAppropriate l LeftP
findAppropriate  (VerticalP l r _) RightP      =   RightP  :  findAppropriate r RightP
findAppropriate  (VerticalP l r _) BottomP     =   LeftP   :  findAppropriate l BottomP
findAppropriate  (VerticalP l r _) TopP        =   LeftP   :  findAppropriate l TopP

--
-- | Bring the pane to the front position in its notebook
--
bringPaneToFront :: Pane alpha beta => alpha -> IO ()
bringPaneToFront pane = do
    let tv = getTopWidget pane
    mbParent <- widgetGetParent tv
    case mbParent of
        Just parent -> do
            let nb = castToNotebook parent
            n <- notebookGetNPages nb
            r <- filterM (\i -> do
                        mbp <-  notebookGetNthPage nb i
                        case mbp of
                            Nothing -> return False
                            Just p -> do
                                mbs <- notebookGetTabLabelText nb p
                                case mbs of
                                    Nothing -> return False
                                    Just s -> return (s == paneName pane))
                                    [0..(n-1)]
            case r of
                [i] -> notebookSetCurrentPage nb i
                otherwise -> return ()
        Nothing -> return ()

--
-- | Get a valid panePath from a standard path.
--
getStandardPanePath :: StandardPath -> PaneLayout -> PanePath
getStandardPanePath sp pl = reverse $ getStandard' sp pl []
    where
    getStandard' _ (TerminalP _ _) p                =   p
    getStandard' (LeftP:sp) (VerticalP l r _) p     =   getStandard' sp l (LeftP:p)
    getStandard' (RightP:sp) (VerticalP l r _) p    =   getStandard' sp r (RightP:p)
    getStandard' (TopP:sp) (HorizontalP t b _) p    =   getStandard' sp t (TopP:p)
    getStandard' (BottomP:sp) (HorizontalP t b _) p =   getStandard' sp b (BottomP:p)
    -- if no match get leftmost topmost
    getStandard' _ (VerticalP l r _) p              =   getStandard' [] l (LeftP:p)
    getStandard' _ (HorizontalP t b _) p            =   getStandard' [] t (TopP:p)

--
-- | Construct a new notebook
--
newNotebook :: IO Notebook
newNotebook = do
    nb <- notebookNew
    notebookSetTabPos nb PosTop
    notebookSetShowTabs nb True
    notebookSetScrollable nb True
    notebookSetPopup nb True
    return nb


--
-- | Get another pane path which points to the other side at the same level
--
otherSide :: PanePath -> Maybe PanePath
otherSide []    =   Nothing
otherSide p     =   let rp = reverse p
                        ae = otherDirection $head rp
                    in Just (reverse $ae : tail rp)

--
-- | Get the opposite direction of a pane direction
--
otherDirection :: PaneDirection -> PaneDirection
otherDirection LeftP    = RightP
otherDirection RightP   = LeftP
otherDirection TopP     = BottomP
otherDirection BottomP  = TopP

--
-- | Get the layout at the given pane path
--
layoutFromPath :: PanePath -> PaneLayout -> PaneLayout
layoutFromPath [] l                             = l
layoutFromPath (TopP:r) (HorizontalP t _ _)     = layoutFromPath r t
layoutFromPath (BottomP:r) (HorizontalP _ b _)  = layoutFromPath r b
layoutFromPath (LeftP:r) (VerticalP l _ _)      = layoutFromPath r l
layoutFromPath (RightP:r) (VerticalP _ ri _)    = layoutFromPath r ri
layoutFromPath pp l                             = error
    $"inconsistent layout " ++ show pp ++ " " ++ show l


getNotebookOrPaned :: PaneMonad alpha => PanePath -> (Widget -> beta) -> alpha beta
getNotebookOrPaned p cf = (widgetGet $["topBox","root"] ++ map paneDirectionToWidgetName p) cf

--
-- | Get the notebook widget for the given pane path
--
getNotebook :: PaneMonad alpha => PanePath -> alpha  Notebook
getNotebook p = getNotebookOrPaned p castToNotebook

--
-- | Get the (gtk) Paned widget for a given path
--
getPaned :: PaneMonad alpha => PanePath -> alpha Paned
getPaned p = getNotebookOrPaned p castToPaned

--
-- | Get the path to the active pane
--
getActivePanePath :: PaneMonad alpha => alpha  (Maybe PanePath)
getActivePanePath = do
    mbPane   <- getActivePaneSt
    case mbPane of
        Nothing -> return Nothing
        Just (paneName,_) -> do
            (pp,_)  <- guiPropertiesFromName paneName
            return (Just (pp))

getActivePanePathOrStandard :: PaneMonad alpha => StandardPath -> alpha  (PanePath)
getActivePanePathOrStandard sp = do
    mbApp <- getActivePanePath
    case mbApp of
        Just app -> return app
        Nothing -> do
            layout <- getLayoutSt
            return (getStandardPanePath sp layout)


--
-- | Get the active notebook
--
getActiveNotebook :: PaneMonad alpha => alpha  (Maybe Notebook)
getActiveNotebook = do
    mbPanePath <- getActivePanePath
    case mbPanePath of
        Just panePath -> do
            nb <- getNotebook panePath
            return (Just nb)
        Nothing -> return Nothing


--
-- | Translates a pane direction to the widget name
--
paneDirectionToWidgetName           :: PaneDirection -> String
paneDirectionToWidgetName TopP      =  "top"
paneDirectionToWidgetName BottomP   =  "bottom"
paneDirectionToWidgetName LeftP     =  "left"
paneDirectionToWidgetName RightP    =  "right"

--
-- | Changes a pane path in the pane map
--
adjustPane :: PaneMonad alpha => PanePath -> PanePath -> alpha ()
adjustPane fromPane toPane  = do
    paneMap     <- getPaneMapSt
    let newMap  = Map.map (\(pp,other) -> do
        if pp == fromPane
            then (toPane,other)
            else (pp,other)) paneMap
    setPaneMapSt newMap

--
-- | Changes the layout for a split
--
adjustLayoutForSplit :: PaneMonad alpha => Direction -> PanePath -> alpha ()
adjustLayoutForSplit  dir path  = do
    layout          <-  getLayoutSt
    let newTerm     =   case dir of
                            Horizontal -> HorizontalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0
                            Vertical   -> VerticalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0
    setLayoutSt     $   adjust path layout newTerm

--
-- | Changes the layout for a collapse

--
adjustLayoutForCollapse :: PaneMonad alpha => PanePath -> alpha ()
adjustLayoutForCollapse path = do
    layout          <-  getLayoutSt
    setLayoutSt     $   adjust path layout (TerminalP Nothing 0)

getSubpath :: PanePath -> PaneLayout -> Maybe PanePath
getSubpath path layout =
    case layoutFromPath path layout of
        TerminalP _ _       -> Nothing
        HorizontalP _ _ _   -> Just (path ++ [TopP])
        VerticalP _ _ _     -> Just (path ++ [LeftP])

--
-- | Changes the layout by replacing element at pane path with replace
--
adjust :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout
adjust pp layout replace    = adjust' pp layout
    where
    adjust' [] _                                = replace
    adjust' (TopP:r)  (HorizontalP tp bp _)     = HorizontalP (adjust' r tp) bp 0
    adjust' (BottomP:r)  (HorizontalP tp bp _)  = HorizontalP tp (adjust' r bp) 0
    adjust' (LeftP:r)  (VerticalP lp rp _)      = VerticalP (adjust' r lp) rp 0
    adjust' (RightP:r)  (VerticalP lp rp _)     = VerticalP lp (adjust' r rp) 0
    adjust' p l = error $"inconsistent layout " ++ show p ++ " " ++ show l

--
-- | Get the widget from a list of strings
--
widgetFromPath :: Widget -> [String] -> IO (Widget)
widgetFromPath w [] = return w
widgetFromPath w (h:t) = do
    children    <- containerGetChildren (castToContainer w)
    names       <- mapM widgetGetName children
    let mbiInd  =  findIndex (== h) names
    case mbiInd of
        Nothing     -> error $"Cant't find widget path " ++ show (h:t)
        Just ind    -> widgetFromPath (children !! ind) t


widgetGet :: PaneMonad alpha => [String] -> (Widget -> b) -> alpha  (b)
widgetGet strL cf = do
    w <- getWindowSt
    r <- liftIO $widgetFromPath (castToWidget w) strL
    return (cf r)

widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b)
widgetGetRel w sl cf = do
    r <- widgetFromPath w sl
    return (cf r)

getUIAction :: PaneMonad alpha => String -> (Action -> a) -> alpha (a)
getUIAction str f = do
    uiManager <- getUIManagerSt
    liftIO $ do
        findAction <- uiManagerGetAction uiManager str
        case findAction of
            Just act -> return (f act)
            Nothing  -> error $"getUIAction can't find action " ++ str