{-# LANGUAGE BangPatterns, ExistentialQuantification, RecursiveDo, ParallelListComp #-}

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

-- | This module defines a user interface implemented using gtk2hs and
-- pango for direct text rendering.

module Yi.UI.Pango (start) where

import Prelude (filter, map, round, length, take, FilePath, (/), zipWith)
import Yi.Prelude 
import Yi.Buffer
import qualified Yi.Editor as Editor
import Yi.Editor hiding (windows)
import Yi.Window
import Yi.Event
import Yi.Keymap
import Yi.Monad
import qualified Yi.UI.Common as Common
import Yi.Config
import Yi.Style

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

import Data.Prototype
import Data.Foldable
import Data.IORef
import Data.List (nub, findIndex, zip, drop, partition, repeat)
import qualified Data.List.PointedList.Circular as PL
import Data.Maybe
import Data.Traversable
import qualified Data.Map as M

import Graphics.UI.Gtk hiding (on, Region, Window, Action, Point, Style)
import qualified Graphics.UI.Gtk.Gdk.Events as Gdk.Events
import qualified Graphics.UI.Gtk as Gtk
import Yi.UI.Gtk.ProjectTree
import Yi.UI.Gtk.Utils
import Yi.UI.Utils

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

data UI = UI
    { uiWindow    :: Gtk.Window
    , uiBox       :: VBox
    , uiCmdLine   :: Label
    , windowCache :: IORef [WinInfo]
    , uiActionCh  :: Action -> IO ()
    , uiConfig    :: UIConfig
    }

data WinInfo = WinInfo
    { coreWin         :: Window
    , shownRegion     :: IORef Region
    , renderer        :: IORef (ConnectId DrawingArea)
    , winMotionSignal :: IORef (Maybe (ConnectId DrawingArea))
    , winLayout       :: PangoLayout
    , winMetrics      :: FontMetrics
    , textview        :: DrawingArea
    , modeline        :: Label
    , widget          :: Box -- ^ Top-level widget for this window.
    }

instance Show WinInfo where
    show w = show (coreWin w)

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

mkFontDesc :: UIConfig -> IO FontDescription
mkFontDesc cfg = do
  f <- fontDescriptionNew
  fontDescriptionSetFamily f (maybe "Monospace" id (configFontName cfg))
  case  configFontSize cfg of
    Just x -> fontDescriptionSetSize f (fromIntegral x)
    -- When the font size is not set, it defaults to 0.0 for the metrics.
    Nothing -> return ()
  return f

askBuffer w b f = fst $ runBuffer w b f

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

  -- rest.
  win <- windowNew
  windowSetDefaultSize win 800 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

  (projectTree, _projectStore) <- projectTreeNew (outCh . singleton)
  modulesTree <- treeViewNew

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

  scrlProject <- scrolledWindowNew Nothing Nothing
  scrolledWindowAddWithViewport scrlProject projectTree
  scrolledWindowSetPolicy scrlProject PolicyAutomatic PolicyAutomatic
  notebookAppendPage tabs scrlProject "Project"

  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

  wc <- newIORef []
  let ui = UI win vb' cmd wc (outCh . singleton) (configUI cfg)

  return (mkUI ui)

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

processEvent :: (Event -> IO ()) -> Gdk.Events.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 :: Gdk.Events.Event -> Maybe Event
gtkToYiEvent (Gdk.Events.Key {Gdk.Events.eventKeyName = keyName, Gdk.Events.eventModifier = evModifier, Gdk.Events.eventKeyChar = char})
    = fmap (\k -> Event k $ (nub $ (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 Gdk.Events.Control = [MCtrl]
            modif Gdk.Events.Alt = [MMeta]
            modif Gdk.Events.Shift = [MShift]
            modif _ = []
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)
    | winkey w == winkey (coreWin c) = do when focused (setFocus c)
                                          (:) <$> syncWin e w c <*> syncWindows e ui ws cs
    | winkey w `elem` map (winkey . coreWin) 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 []

syncWin :: Editor -> Window -> WinInfo -> IO WinInfo
syncWin e w wi = do
  let b = findBufferWith (bufkey w) e
      reg = askBuffer w b winRegionB
  logPutStrLn $ "Updated one: " ++ show w ++ " to " ++ show reg
  writeRef (shownRegion wi) reg
  return (wi {coreWin = w})

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

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

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

  -- retrieve the clicked offset.
  (_,layoutIndex,_) <- layoutXYToIndex (winLayout w) (Gdk.Events.eventX event) (Gdk.Events.eventY event)
  r <- readRef (shownRegion w)
  let p1 = regionStart r + fromIntegral layoutIndex

  -- maybe focus the window
  logPutStrLn $ "Clicked inside window: " ++ show w
  wCache <- readIORef (windowCache ui)
  let Just idx = findIndex (((==) `on` (winkey . coreWin)) w) wCache
      focusWindow = modA windowsA (fromJust . PL.move idx)

  case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
     (Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> do
       writeRef (winMotionSignal w) =<< Just <$> onMotionNotify (textview w) False (handleMove ui w p1)

     _ -> do maybe (return ()) signalDisconnect =<< readRef (winMotionSignal w)
             writeRef (winMotionSignal w) Nothing
             


  let editorAction = do
        b <- gets $ (bkey . findBufferWith (bufkey $ coreWin w))
        case (Gdk.Events.eventClick event, Gdk.Events.eventButton event) of
          (Gdk.Events.SingleClick, Gdk.Events.LeftButton) -> do
              focusWindow
              withGivenBufferAndWindow0 (coreWin w) b $ moveTo p1
          (Gdk.Events.SingleClick, _) -> focusWindow
          (Gdk.Events.ReleaseClick, Gdk.Events.MiddleButton) -> do
            txt <- getRegE
            withGivenBufferAndWindow0 (coreWin w) b $ do
              pointB >>= setSelectionMarkPointB
              moveTo p1
              insertN txt

          _ -> return ()

  uiActionCh ui (makeAction editorAction)
  return True

handleMove :: UI -> WinInfo -> Point -> Gdk.Events.Event -> IO Bool
handleMove ui w p0 event = do
  logPutStrLn $ "Motion: " ++ show (Gdk.Events.eventX event, Gdk.Events.eventY event)

  -- retrieve the clicked offset.
  (_,layoutIndex,_) <- layoutXYToIndex (winLayout w) (Gdk.Events.eventX event) (Gdk.Events.eventY event)
  r <- readRef (shownRegion w)
  let p1 = regionStart r + fromIntegral layoutIndex


  let editorAction = do
        txt <- withBuffer0 $ do
           if p0 /= p1 
            then Just <$> do
              m <- selMark <$> askMarks
              setMarkPointB m p0
              moveTo p1
              setVisibleSelection True
              readRegionB =<< getSelectRegionB
            else return Nothing
        maybe (return ()) setRegE txt

  uiActionCh ui (makeAction editorAction)
  -- drawWindowGetPointer (textview w) -- be ready for next message.
  return True



-- | Make A new window
newWindow :: Editor -> UI -> Window -> FBuffer -> IO WinInfo
newWindow e ui w b = mdo
    f <- mkFontDesc (uiConfig ui)

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

    v <- drawingAreaNew
    widgetModifyFont v (Just f)
    widgetAddEvents v [Button1MotionMask]
    widgetModifyBg v StateNormal $ mkCol False $ Yi.Style.background $ baseAttributes $ configStyle $ uiConfig ui

    box <- if isMini w
     then do
      widgetSetSizeRequest v (-1) 1

      prompt <- labelNew (Just $ identString 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
      vb <- vBoxNew False 1
      set vb [ containerChild := v,
               containerChild := ml,
               boxChildPacking ml := PackNatural]
      return (castToBox vb)
     
    sig       <- newIORef =<< (v `onExpose` render e ui b win)
    rRef      <- newIORef (askBuffer w b winRegionB)
    context   <- widgetCreatePangoContext v
    layout    <- layoutEmpty context
    language  <- contextGetLanguage context
    metrics   <- contextGetMetrics context f language
    motionSig <- newIORef Nothing

    layoutSetWrap layout WrapAnywhere
    layoutSetFontDescription layout (Just f)

    let win = WinInfo { coreWin   = w
                      , winLayout = layout
                      , winMetrics = metrics
                      , winMotionSignal = motionSig
                      , textview  = v
                      , modeline  = ml
                      , widget    = box
                      , renderer  = sig
                      , shownRegion = rRef
                      }

    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 (bufkey win) e
  liftIO $ do w <- newWindow e i win buf
              set (uiBox i) [containerChild := widget w,
                             boxChildPacking (widget w) := if isMini (coreWin w) then PackNatural else PackGrow]
              textview w `onButtonRelease` handleClick i w
              textview w `onButtonPress` handleClick i w
              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 (show $ statusLine e)]

    cache <- readRef $ windowCache ui
    logPutStrLn $ "syncing: " ++ show ws
    logPutStrLn $ "with: " ++ show cache
    cache' <- syncWindows e ui (toList $ PL.withFocus $ ws) cache
    logPutStrLn $ "Gives: " ++ show cache'
    writeRef (windowCache ui) cache'
    forM_ cache' $ \w -> do
        let b = findBufferWith (bufkey (coreWin w)) e
        --when (not $ null $ pendingUpdates b) $ 
        do 
           sig <- readIORef (renderer w)
           signalDisconnect sig
           writeRef (renderer w) =<< (textview w `onExpose` render e ui b w)
           widgetQueueDraw (textview w)

winEls :: Point -> Int -> BufferM Yi.Buffer.Size
winEls tospnt h = savingPointB $ do
             moveTo tospnt
             gotoLnFrom h
             p <- pointB
             return (p ~- tospnt)

render :: Editor -> UI -> FBuffer -> WinInfo -> t -> IO Bool
render e ui b w _ev = do
  reg <- readRef (shownRegion w)
  drawWindow <- widgetGetDrawWindow $ textview w
  (width, height) <- widgetGetSize $ textview w

  let win               = coreWin w
      [width', height'] = map fromIntegral [width, height]
      metrics           = winMetrics w
      layout            = winLayout w
      winh              = round (height' / (ascent metrics + descent metrics))

      (point, text)     = askBuffer win b $ do
                            numChars <- winEls (regionStart reg) winh
                            p        <- pointB
                            content  <- nelemsB' numChars (regionStart reg)
                            return (p, content)

  layoutSetWidth layout (Just width')
  layoutSetText layout text

  (_,bos,_) <- layoutXYToIndex layout width' height' 
  let r' = mkRegion (regionStart reg) (fromIntegral bos + regionStart reg)

  -- Scroll the window when the cursor goes out of it:
  logPutStrLn $ "prewin: " ++ show r'
  logPutStrLn $ "point: " ++ show point
  r'' <- if inRegion point r'
    then return r'
    else do
      logPutStrLn $ "point moved out of visible region"

      let (topOfScreen, numChars, text') = askBuffer win b $ do
            top      <- indexOfSolAbove (winh `div` 2)
            numChars <- winEls top winh
            content  <- nelemsB' numChars top
            return (top, numChars, content)

      layoutSetText layout text'

      return $ mkSizeRegion topOfScreen numChars

  writeRef (shownRegion w) r''
  logPutStrLn $ "updated: " ++ show r''

  -- add color attributes.
  let picture = askBuffer win b $ attributesPictureAndSelB sty (regex e) r''
      sty = extractValue $ configTheme (uiConfig ui)
      strokes = [(start,s,end) | ((start, s), end) <- zip picture (drop 1 (map fst picture) ++ [regionEnd r'']),
                  s /= emptyAttributes]
      rel p = fromIntegral (p - regionStart r'')
      allAttrs = [gen (rel p1) (rel p2) (mkCol isFg col) 
                  | (p1,Attributes fg bg _rv,p2) <- strokes, 
                  ((isFg,gen),col) <- zip [(True,AttrForeground), (False,AttrBackground)] [fg,bg],
                  col /= Default]

  layoutSetAttributes layout allAttrs

  (PangoRectangle curx cury curw curh, _) <- layoutGetCursorPos layout (fromPoint (point - regionStart r''))

  gc <- gcNew drawWindow
  drawLayout drawWindow gc 0 0 layout

  -- paint the cursor   
  gcSetValues gc (newGCValues { Gtk.foreground = mkCol True $ Yi.Style.foreground $ baseAttributes $ configStyle $ uiConfig ui })
  drawLine drawWindow gc (round curx, round cury) (round $ curx + curw, round $ cury + curh) 
  return True

prepareAction :: UI -> IO (EditorM ())
prepareAction ui = do
    wins <- readRef (windowCache ui)
    let ws = fmap coreWin wins
    rs <- mapM (readRef . shownRegion) wins
    logPutStrLn $ "new wins: " ++ show wins
    logPutStrLn $ "new regs: " ++ show rs
    heights <- forM wins $ \w -> do
      (_, h) <- widgetGetSize $ textview w
      let metrics = winMetrics w
      return $ round ((fromIntegral h) / (ascent metrics + descent metrics))
    return $ do
      let updWin w r = do
             withGivenBufferAndWindow0 w (bufkey w) $ do
                 Just (MarkSet f _ _ t) <- getMarks w
                 setMarkPointB f (regionStart r)
                 setMarkPointB t (regionEnd   r)
      sequence_ $ zipWith updWin ws rs
      modA windowsA (computeHeights $ heights ++ repeat 0)
      -- TODO: bos needs to be set also.
      -- FIXME: Get rid of 'repeat 0'; it seems to be necessary because no
      -- windows are available when this is first executed.

-- | Calculate window heights, given all the windows and current height.
computeHeights :: [Int] -> PL.PointedList Window -> PL.PointedList Window
computeHeights heights ws = fst $ runState (Data.Traversable.mapM distribute ws) heights

distribute :: Window -> State [Int] Window
distribute win = case isMini win of
                 True -> return win {height = 1}
                 False -> do h <- gets head
                             modify tail
                             return win {height = h}

reloadProject :: UI -> FilePath -> IO ()
reloadProject _ _ = return ()

mkCol :: Bool -- ^ is foreground?
      -> Yi.Style.Color -> Gtk.Color
mkCol True  Default = Color 0 0 0
mkCol False Default = Color maxBound maxBound maxBound
mkCol _ (RGB x y z) = Color (fromIntegral x * 256)
                            (fromIntegral y * 256)
                            (fromIntegral z * 256)