{-# LANGUAGE BangPatterns, ExistentialQuantification #-}

-- Copyright (c) 2007, 2008 Jean-Philippe Bernardy

-- | This module defines a user interface implemented using gtk2hs.

module Yi.UI.Gtk (start) where

import Prelude (filter, map, round, length, take, FilePath)
import Yi.Prelude 
import Yi.Accessor
import Yi.Buffer.Implementation (inBounds, Update(..), UIUpdate(..))
import Yi.Buffer
import Yi.Buffer.HighLevel (setSelectionMarkPointB)
import qualified Yi.Editor as Editor
import Yi.Editor hiding (windows)
import qualified Yi.Window as Window
import Yi.Window (Window)
import Yi.Event
import Yi.Keymap
import Yi.Debug
import Yi.Monad
import qualified Yi.UI.Common as Common
import Yi.Config
import Yi.Style hiding (modeline)
import qualified Yi.WindowSet as WS

import Control.Applicative
import Control.Concurrent ( yield )
import Control.Monad (ap)
import Control.Monad.Reader (liftIO, when, MonadIO)
import Control.Monad.State (runState, State, gets, modify)

import Data.Foldable
import Data.IORef
import Data.List ( nub, findIndex, sort )
import Data.Maybe
import Data.Traversable
import Data.Unique
import qualified Data.Map as M

import Graphics.UI.Gtk hiding ( Window, Event, Action, Point, Style )
import qualified Graphics.UI.Gtk as Gtk
import qualified Graphics.UI.Gtk.ModelView as MView
import Yi.UI.Gtk.ProjectTree
import Yi.UI.Gtk.Utils
import Shim.ProjectContent
import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8

------------------------------------------------------------------------

data UI = UI { uiWindow :: Gtk.Window
             , uiBox :: VBox
             , uiCmdLine :: Label
             , uiBuffers :: IORef (M.Map BufferRef TextBuffer)
             , tagTable :: TextTagTable
             , windowCache :: IORef [WinInfo]
             , uiActionCh :: Action -> IO ()
             , uiConfig :: UIConfig
             , uiFilesStore   :: MView.TreeStore ProjectItem
             , uiModulesStore :: MView.TreeStore ProjectItem
             }

data WinInfo = WinInfo
    {
      bufkey      :: !BufferRef         -- ^ the buffer this window opens to
    , wkey        :: !Unique
    , textview    :: TextView
    , modeline    :: Label
    , widget      :: Box            -- ^ Top-level widget for this window.
    , isMini      :: Bool
    }

instance Show WinInfo where
    show w = "W" ++ show (hashUnique $ wkey w) ++ " on " ++ show (bufkey w)

-- | Get the identification of a window.
winkey :: WinInfo -> (Bool, BufferRef)
winkey w = (isMini w, bufkey w)

mkUI :: UI -> Common.UI
mkUI ui = Common.UI
  {
   Common.main                  = main ui,
   Common.end                   = postGUIAsync $ end,
   Common.suspend               = postGUIAsync $ windowIconify (uiWindow ui),
   Common.refresh               = postGUIAsync . refresh                 ui,
   Common.prepareAction         =                prepareAction           ui,
   Common.reloadProject         = postGUIAsync . reloadProject           ui
  }

mkFontDesc :: UIConfig -> IO FontDescription
mkFontDesc cfg = do
  f <- fontDescriptionNew
  fontDescriptionSetFamily f "Monospace"
  case  configFontSize cfg of
    Just x -> fontDescriptionSetSize f (fromIntegral x)
    Nothing -> return ()
  return f

-- | Initialise the ui
start :: UIBoot
start cfg ch outCh _ed = do
  unsafeInitGUIForThreadedRTS

  -- rest.
  win <- windowNew
  windowSetDefaultSize win 500 700
  --windowFullscreen win
  ico <- loadIcon "yi+lambda-fat.32.png"
  windowSetIcon win ico

  onKeyPress win (processEvent ch)

  paned <- hPanedNew

  vb <- vBoxNew False 1  -- Top-level vbox

  (filesTree,   filesStore) <- projectTreeNew outCh  
  (modulesTree, modulesStore) <- projectTreeNew outCh  

  tabs <- notebookNew
  set tabs [notebookTabPos := PosBottom]
  panedAdd1 paned tabs

  scrlProject <- scrolledWindowNew Nothing Nothing
  scrolledWindowAddWithViewport scrlProject filesTree
  scrolledWindowSetPolicy scrlProject PolicyAutomatic PolicyAutomatic
  notebookAppendPage tabs scrlProject "Files"

  scrlModules <- scrolledWindowNew Nothing Nothing
  scrolledWindowAddWithViewport scrlModules modulesTree
  scrolledWindowSetPolicy scrlModules PolicyAutomatic PolicyAutomatic
  notebookAppendPage tabs scrlModules "Modules"

  vb' <- vBoxNew False 1
  panedAdd2 paned vb'

  set win [ containerChild := vb ]
  onDestroy win mainQuit

  cmd <- labelNew Nothing
  set cmd [ miscXalign := 0.01 ]
  widgetModifyFont cmd =<< Just <$> mkFontDesc (configUI cfg)

  set vb [ containerChild := paned,
           containerChild := cmd,
           boxChildPacking cmd  := PackNatural ]

  -- use our magic threads thingy (http://haskell.org/gtk2hs/archives/2005/07/24/writing-multi-threaded-guis/)
  timeoutAddFull (yield >> return True) priorityDefaultIdle 50

  widgetShowAll win

  bufs <- newIORef M.empty
  wc <- newIORef []
  tt <- textTagTableNew

  let ui = UI win vb' cmd bufs tt wc outCh (configUI cfg) filesStore modulesStore

  return (mkUI ui)

main :: UI -> IO ()
main _ui =
    do logPutStrLn "GTK main loop running"
       mainGUI

instance Show Gtk.Event where
    show (Key _eventRelease _eventSent _eventTime _eventModifier' _eventWithCapsLock _eventWithNumLock
                  _eventWithScrollLock _eventKeyVal eventKeyName' eventKeyChar')
        = "<modifier>" ++ " " ++ show eventKeyName' ++ " " ++ show eventKeyChar'
    show _ = "Not a key event"


processEvent :: (Event -> IO ()) -> Gtk.Event -> IO Bool
processEvent ch ev = do
  -- logPutStrLn $ "Gtk.Event: " ++ show ev
  -- logPutStrLn $ "Event: " ++ show (gtkToYiEvent ev)
  case gtkToYiEvent ev of
    Nothing -> logPutStrLn $ "Event not translatable: " ++ show ev
    Just e -> ch e
  return True

gtkToYiEvent :: Gtk.Event -> Maybe Event
gtkToYiEvent (Key {eventKeyName = keyName, eventModifier = evModifier, eventKeyChar = char})
    = fmap (\k -> Event k $ (nub $ sort $ (if isShift then filter (/= MShift) else id) $ concatMap modif evModifier)) key'
      where (key',isShift) =
                case char of
                  Just c -> (Just $ KASCII c, True)
                  Nothing -> (M.lookup keyName keyTable, False)
            modif Control = [MCtrl]
            modif Alt = [MMeta]
            modif Shift = [MShift]
            modif _ = [] -- Use underscore so we don't depend on the differences between gtk2hs versions
gtkToYiEvent _ = Nothing

-- | Map GTK long names to Keys
keyTable :: M.Map String Key
keyTable = M.fromList
    [("Down",       KDown)
    ,("Up",         KUp)
    ,("Left",       KLeft)
    ,("Right",      KRight)
    ,("Home",       KHome)
    ,("End",        KEnd)
    ,("BackSpace",  KBS)
    ,("Delete",     KDel)
    ,("Page_Up",    KPageUp)
    ,("Page_Down",  KPageDown)
    ,("Insert",     KIns)
    ,("Escape",     KEsc)
    ,("Return",     KEnter)
    ,("Tab",        KTab)
    ,("ISO_Left_Tab", KTab)
    ]

-- | Clean up and go home
end :: IO ()
end = mainQuit

-- | Synchronize the windows displayed by GTK with the status of windows in the Core.
syncWindows :: Editor -> UI -> [(Window, Bool)] -- ^ windows paired with their "isFocused" state.
            -> [WinInfo] -> IO [WinInfo]
syncWindows e ui (wfocused@(w,focused):ws) (c:cs)
    | Window.winkey w == winkey c = do when focused (setFocus c)
                                       return (c:) `ap` syncWindows e ui ws cs
    | Window.winkey w `elem` map winkey cs = removeWindow ui c >> syncWindows e ui (wfocused:ws) cs
    | otherwise = do c' <- insertWindowBefore e ui w c
                     when focused (setFocus c')
                     return (c':) `ap` syncWindows e ui ws (c:cs)
syncWindows e ui ws [] = mapM (insertWindowAtEnd e ui) (map fst ws)
syncWindows _e ui [] cs = mapM_ (removeWindow ui) cs >> return []

setFocus :: WinInfo -> IO ()
setFocus w = do
  logPutStrLn $ "gtk focusing " ++ show w
  hasFocus <- widgetIsFocus (textview w)
  when (not hasFocus) $ widgetGrabFocus (textview w)

removeWindow :: UI -> WinInfo -> IO ()
removeWindow i win = containerRemove (uiBox i) (widget win)

instance Show Click where
    show x = case x of
               SingleClick  -> "SingleClick "
               DoubleClick  -> "DoubleClick "
               TripleClick  -> "TripleClick "
               ReleaseClick -> "ReleaseClick"

handleClick :: UI -> WinInfo -> Gtk.Event -> IO Bool
handleClick ui w event = do
  -- logPutStrLn $ "Click: " ++ show (eventX e, eventY e, eventClick e)

  -- retrieve the clicked offset.
  let tv = textview w
  let wx = round (eventX event)
  let wy = round (eventY event)
  (bx, by) <- textViewWindowToBufferCoords tv TextWindowText (wx,wy)
  iter <- textViewGetIterAtLocation tv bx by
  p1 <- Point <$> get iter textIterOffset

  -- maybe focus the window
  logPutStrLn $ "Clicked inside window: " ++ show w
  wCache <- readIORef (windowCache ui)
  let Just idx = findIndex ((wkey w ==) . wkey) wCache
      focusWindow = modifyWindows (WS.focusIndex idx)
  logPutStrLn $ "Will focus to index: " ++ show (findIndex ((wkey w ==) . wkey) wCache)

  let editorAction = do
        b <- gets $ (bkey . findBufferWith (bufkey w))
        case (eventClick event, eventButton event) of
          (SingleClick, LeftButton) -> do
              focusWindow
              withGivenBuffer0 b $ do moveTo p1 -- as a side effect we forget the prefered column
                                      setVisibleSelection True
          (SingleClick, _) -> focusWindow
          (ReleaseClick, LeftButton) -> do
            p0 <- withGivenBuffer0 b $ pointB
            if p1 == p0
              then withGivenBuffer0 b $ setVisibleSelection False
              else do txt <- withGivenBuffer0 b $ do setMarkPointB staticSelMark p1
                                                     let [i,j] = sort [p1,p0]
                                                     nelemsB' (j~-i) i
                      setRegE txt
          (ReleaseClick, MiddleButton) -> do
            txt <- getRegE
            withGivenBuffer0 b $ do
              pointB >>= setSelectionMarkPointB
              moveTo p1
              insertN txt

          _ -> return ()

  uiActionCh ui (makeAction editorAction)
  return True


-- | Make A new window
newWindow :: UI -> Bool -> FBuffer -> IO WinInfo
newWindow ui mini b = do
    f <- mkFontDesc (uiConfig ui)

    ml <- labelNew Nothing
    widgetModifyFont ml (Just f)
    set ml [ miscXalign := 0.01 ] -- so the text is left-justified.

    v <- textViewNew
    textViewSetWrapMode v WrapChar
    widgetModifyFont v (Just f)

    box <- if mini
     then do
      widgetSetSizeRequest v (-1) 1

      prompt <- labelNew (Just $ name b)
      widgetModifyFont prompt (Just f)

      hb <- hBoxNew False 1
      set hb [ containerChild := prompt,
               containerChild := v,
               boxChildPacking prompt := PackNatural,
               boxChildPacking v := PackGrow]

      return (castToBox hb)
     else do
      scroll <- scrolledWindowNew Nothing Nothing
      set scroll [scrolledWindowPlacement := if configLeftSideScrollBar $ uiConfig $ ui then CornerTopRight else CornerTopLeft,
                  scrolledWindowVscrollbarPolicy := if configAutoHideScrollBar $ uiConfig $ ui then PolicyAlways else PolicyAutomatic,
                  scrolledWindowHscrollbarPolicy := PolicyAutomatic,
                  containerChild := v]

      vb <- vBoxNew False 1
      set vb [ containerChild := scroll,
               containerChild := ml,
               boxChildPacking ml := PackNatural]
      return (castToBox vb)

    gtkBuf <- getGtkBuffer ui b

    textViewSetBuffer v gtkBuf

    k <- newUnique
    let win = WinInfo {
                     bufkey    = (keyB b)
                   , wkey      = k
                   , textview  = v
                   , modeline  = ml
                   , widget    = box
                   , isMini    = mini
              }
    return win

insertWindowBefore :: Editor -> UI -> Window -> WinInfo -> IO WinInfo
insertWindowBefore e i w _c = insertWindow e i w

insertWindowAtEnd :: Editor -> UI -> Window -> IO WinInfo
insertWindowAtEnd e i w = insertWindow e i w

insertWindow :: Editor -> UI -> Window -> IO WinInfo
insertWindow e i win = do
  let buf = findBufferWith (Window.bufkey win) e
  liftIO $ do w <- newWindow i (Window.isMini win) buf
              set (uiBox i) [containerChild := widget w,
                             boxChildPacking (widget w) := if isMini w then PackNatural else PackGrow]
              textview w `onButtonRelease` handleClick i w
              textview w `onButtonPress` handleClick i w
              set (textview w) [textViewWrapMode := if configLineWrap $ uiConfig $ i then WrapChar else WrapNone]
              widgetShowAll (widget w)
              return w

refresh :: UI -> Editor -> IO ()
refresh ui e = do
    let ws = Editor.windows e
    let takeEllipsis s = if length s > 132 then take 129 s ++ "..." else s
    set (uiCmdLine ui) [labelText := takeEllipsis (statusLine e)]

    cache <- readRef $ windowCache ui
    forM_ (buffers e) $ \buf -> when (not $ null $ pendingUpdates $ buf) $ do
      gtkBuf <- getGtkBuffer ui buf
      forM_ ([u | TextUpdate u <- pendingUpdates buf]) $ applyUpdate gtkBuf
      let (size,p) = runBufferDummyWindow buf ((,) <$> sizeB <*> pointB)
      replaceTagsIn ui (inBounds (p-100) size) (inBounds (p+100) size) buf gtkBuf
      forM_ ([(s,s+~l) | StyleUpdate s l <- pendingUpdates buf]) $ \(s,e') -> replaceTagsIn ui (inBounds s size) (inBounds e' size) buf gtkBuf
    logPutStrLn $ "syncing: " ++ show ws
    logPutStrLn $ "with: " ++ show cache
    cache' <- syncWindows e ui (toList $ WS.withFocus $ ws) cache
    logPutStrLn $ "Gives: " ++ show cache'
    writeRef (windowCache ui) cache'
    forM_ cache' $ \w ->
        do let buf = findBufferWith (bufkey w) e
           gtkBuf <- getGtkBuffer ui buf

           let (Point p0) = runBufferDummyWindow buf pointB
           let (Point p1) = runBufferDummyWindow buf (getMarkPointB staticSelMark)
           let (showSel) = runBufferDummyWindow buf (getA highlightSelectionA)
           i <- textBufferGetIterAtOffset gtkBuf p0
           if showSel 
              then do
                 i' <- textBufferGetIterAtOffset gtkBuf p1
                 textBufferSelectRange gtkBuf i i'
              else do
                 textBufferPlaceCursor gtkBuf i
           insertMark <- textBufferGetInsert gtkBuf
           textViewScrollMarkOnscreen (textview w) insertMark
           let txt = runBufferDummyWindow buf getModeLine
           set (modeline w) [labelText := txt]

replaceTagsIn :: UI -> Point -> Point -> FBuffer -> TextBuffer -> IO ()
replaceTagsIn ui from to buf gtkBuf = do
  i <- textBufferGetIterAtOffset gtkBuf (fromPoint from)
  i' <- textBufferGetIterAtOffset gtkBuf (fromPoint to)
  let styleSpans = runBufferDummyWindow buf (strokesRangesB Nothing from to)
  textBufferRemoveAllTags gtkBuf i i'
  forM_ (concat styleSpans) $ \(l,s,r) -> do
    f <- textBufferGetIterAtOffset gtkBuf (fromPoint l)
    t <- textBufferGetIterAtOffset gtkBuf (fromPoint r)
    forM s $ \a -> do 
      tag <- styleToTag ui a
      textBufferApplyTag gtkBuf tag f t

applyUpdate :: TextBuffer -> Update -> IO ()
applyUpdate buf (Insert (Point p) _ s) = do
  i <- textBufferGetIterAtOffset buf p
  textBufferInsert buf i (LazyUTF8.toString s)

applyUpdate buf (Delete p _ s) = do
  i0 <- textBufferGetIterAtOffset buf (fromPoint p)
  i1 <- textBufferGetIterAtOffset buf (fromPoint p + length (LazyUTF8.toString s))
  textBufferDelete buf i0 i1

styleToTag :: UI -> Yi.Style.Attr -> IO TextTag
styleToTag ui a = case a of
                 (Foreground col) -> tagOf textTagForeground col
                 (Background col) -> tagOf textTagBackground col
 where tagOf attr col = do
         let fgText = colorToText col
         mtag <- textTagTableLookup (tagTable ui) fgText
         case mtag of
           Just x -> return x
           Nothing -> do x <- textTagNew (Just fgText)
                         set x [attr := fgText]
                         textTagTableAdd (tagTable ui) x
                         return x

prepareAction :: UI -> IO (EditorM ())
prepareAction ui = do
    -- compute the heights of all windows (in number of lines)
    gtkWins <- readRef (windowCache ui)
    heights <- forM gtkWins $ \w -> do
                     let gtkWin = textview w
                     d <- widgetGetDrawWindow gtkWin
                     (_w,h) <- drawableGetSize d
                     (_,y0) <- textViewWindowToBufferCoords gtkWin TextWindowText (0,0)
                     (i0,_) <- textViewGetLineAtY gtkWin y0
                     l0 <- get i0 textIterLine
                     (_,y1) <- textViewWindowToBufferCoords gtkWin TextWindowText (0,h)
                     (i1,_) <- textViewGetLineAtY gtkWin y1
                     l1 <- get i1 textIterLine
                     return (l1 - l0)
    -- updates the heights of the windows
    return $ 
      modifyWindows (\ws -> if WS.size ws == length heights 
                              then fst $ runState (mapM distribute ws) heights
                              else trace ("INFO: updates the heights of the windows: unmatching lengths") ws)

reloadProject :: UI -> FilePath -> IO ()
reloadProject ui fpath = do
  (files,mods) <- loadProject fpath
  loadProjectTree (uiFilesStore   ui) files
  loadProjectTree (uiModulesStore ui) mods

distribute :: Window -> State [Int] Window
distribute win = do
  h <- gets hd
  modify tail
  return win {Window.height = h}
      where hd (h:_) = h
            hd [] = error "distribute: non-matching list lengths"

getGtkBuffer :: UI -> FBuffer -> IO TextBuffer
getGtkBuffer ui b = do
    let bufsRef = uiBuffers ui
    bufs <- readRef bufsRef
    gtkBuf <- case M.lookup (bkey b) bufs of
      Just gtkBuf -> return gtkBuf
      Nothing -> newGtkBuffer ui b
    modifyRef bufsRef (M.insert (bkey b) gtkBuf)
    return gtkBuf

-- FIXME: when a buffer is deleted its GTK counterpart should be too.
newGtkBuffer :: UI -> FBuffer -> IO TextBuffer
newGtkBuffer ui b = do
  buf <- textBufferNew (Just (tagTable ui))
  let (txt,sz) = runBufferDummyWindow b $ do
                      revertPendingUpdatesB
                      (,) <$> elemsB <*> sizeB
  textBufferSetText buf txt
  replaceTagsIn ui 0 sz b buf
  return buf