{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module LGtk.Backend.Gtk
    ( runWidget
    ) where

import Control.Category
import Control.Monad
import Control.Exception
import Control.Monad.State
import Control.Monad.Trans.Control
import Control.Concurrent
import Data.Maybe
import Data.List hiding (union)
import Prelude hiding ((.), id)

import Graphics.UI.Gtk hiding (Widget, Release, Modifier)
import qualified Graphics.UI.Gtk as Gtk

import Data.LensRef
import Data.LensRef.Default
import LGtk.Effects
import LGtk.Key
import LGtk.Widgets

import Diagrams.Prelude
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Internal

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

runWidget :: (forall m . (EffIORef m, MonadFix m) => Widget m) -> IO ()
runWidget w = runWidget' runRegister' w

runRegister' :: IO () -> Wrap (Register IO) a -> IO (a, IO ())
runRegister' pa (Wrap m) = runRegister (newChan' pa) m
  where
    newChan' pa = do
        ch <- newChan
        return (pa >> readChan ch, writeChan ch)

{- |
Run a Gtk widget description.

The widget is shown in a window and the thread enters into the Gtk event cycle.
It leaves the event cycle when the window is closed.
-}
runWidget' :: (MonadRegister m, MonadBaseControl IO (EffectM m))
    => (forall a . IO () -> m a -> IO (a, IO ())) -> Widget m -> IO ()
runWidget' run desc = gtkContext $ \postGUISync -> do
    postActionsRef <- newMVar $ return ()
    let addPostAction m = modifyMVar_ postActionsRef $ \n -> return $ n >> m
        runPostActions = join $ modifyMVar postActionsRef $ \m -> return (return (), m)
    (widget, actions) <- run runPostActions $ do
        w <- runWidget_ addPostAction postGUISync desc
        liftIO' runPostActions
        return w
    _ <- forkIO $ actions
    return widget

gtkContext :: ((forall a . IO a -> IO a) -> IO SWidget) -> IO ()
gtkContext m = do
    _ <- unsafeInitGUIForThreadedRTS
    tid <- myThreadId
    let post :: forall a . IO a -> IO a
        post e = do
            tid' <- myThreadId
            if tid' == tid then e else postGUISync e
    c <- m post
    window <- windowNew
    set window [ containerBorderWidth := 10, containerChild := snd c ]
    _ <- window `on` deleteEvent $ liftIO mainQuit >> return False
    widgetShowAll window
    mainGUI

type SWidget = (IO (), Gtk.Widget)

-- | Run an @IO@ parametrized interface description with Gtk backend
runWidget_
    :: forall m . (MonadRegister m, MonadBaseControl IO (EffectM m))
    => (IO () -> IO ())
    -> (forall a . IO a -> IO a)
    -> Widget m
    -> m SWidget
runWidget_ post' post = toWidget
 where
    liftIO'' :: IO a -> m a
    liftIO'' = liftIO' . post

    -- type Receive n m k a = (RegionStatusChange -> n ()) -> m (a -> k ())
    reg :: Receive m a -> ((a -> IO ()) -> IO (RegionStatusChange -> IO ())) -> m (RegionStatusChange -> IO ())
    reg s f = do
        re <- registerCallback s
        u <- liftEffectM $ liftBaseWith $ \unr -> f $ \x -> do
            _ <- unr $ re x
            return ()
        onRegionStatusChange (liftIO'' . u $)
        return u

    ger :: Eq a => (RegionStatusChange -> IO ()) -> RefReader m a -> (a -> IO ()) -> m ()
    ger hd s f = liftM (const ()) $ onChangeSimple s $ \a -> liftIO'' $ do
        hd Block
        f a
        hd Unblock

    nhd :: RegionStatusChange -> IO ()
    nhd = const $ return ()

    toWidget :: Widget m -> m SWidget
    toWidget m = m >>= \i -> case i of

        Label s -> do
            w <- liftIO'' $ labelNew Nothing
            ger nhd s $ labelSetLabel w
            return' w

        Canvas w h sc_ me keyh r diaFun -> mkCanvas me r diaFun where

         mkCanvas
            :: forall b da
            .  (Monoid da, Semigroup da, Eq b)
            => ((MouseEvent da, Dia da) -> Modifier m ())
            -> RefReader m b
            -> (b -> Dia da)
            -> m SWidget
         mkCanvas me r diaFun = do

          cur <- liftIO' $ newMVar Nothing
          cur' <- liftIO' $ newMVar Nothing
          v <- liftIO' newEmptyMVar

          (canvasDraw, canvas, af, dims, drawingAreaGetDrawWindow') <- liftIO'' $ do
            canvas <- drawingAreaNew
            widgetAddEvents canvas [PointerMotionMask, KeyPressMask]
            widgetSetCanFocus canvas True
            af <- aspectFrameNew 0.5 0.5 (Just $ fromIntegral w / fromIntegral h)
            _ <- canvas `onSizeRequest` return (Requisition w h)
            _ <- containerAdd af canvas
            realized <- newMVar False
            _ <- onRealize canvas $ swapMVar realized True >> return ()
--            _ <- afterRealize canvas $ swapMVar realized False >> return ()
            let
              drawingAreaGetDrawWindow' = do
                b <- readMVar realized
                if b then catchJust select (liftM Just $ widgetGetDrawWindow canvas) (const $ return Nothing)
                     else return Nothing
                where
                    select :: SomeException -> Maybe ()
                    select s | "widgetGetDrawWindow" `isInfixOf` show s = Just ()
                    select _ = Nothing
                    

              dims win = do
                (w, h) <- drawableGetSize win
                let (w', h') = (fromIntegral w, fromIntegral h)
                let sc = w' / sc_
                return (sc, w', h', w, h)

              tr sc w h dia = translate (r2 (w/2, h/2)) $ dia # scaleY (-1) # scale sc `atop` rect w h # fc white # lw 0

              draw dia_ = do
                _ <- swapMVar cur $ Just dia_
                let dia = freeze $ clearValue dia_
                win <- drawingAreaGetDrawWindow'
                case win of
                  Nothing -> return ()
                  Just win -> do
                    (sc, w, h, wi, he) <- dims win
                    drawWindowBeginPaintRect win $ Rectangle 0 0 wi he
                    renderWithDrawable win $ snd $ renderDia Cairo (CairoOptions "" (Width w) RenderOnly True) $ tr sc w h dia
                    drawWindowEndPaint win

            return (draw, canvas, af, dims, drawingAreaGetDrawWindow')

          let -- compCoords :: (Double, Double) -> IO (MousePos a)
              compCoords_ (x,y) = do
                win <- drawingAreaGetDrawWindow'
                case win of
                  Nothing -> return Nothing
                  Just win -> do
                    (sc, w, h, _, _) <- dims win
                    d <- readMVar cur
                    let p = p2 ((x - w / 2) / sc, (h / 2 - y) / sc)
                    return $ Just (MousePos p $ maybe mempty (`sample` p) d, fromMaybe mempty d)

          _ <- reg me $ \re -> do
              let compCoords :: MonadIO em
                        => em (Double, Double)
                        -> ((MousePos da, Dia da) -> (MouseEvent da, Dia da))
                        -> em ()
                  compCoords eventCoordinates f = do
                    c <- eventCoordinates
                    liftIO $ compCoords_ c >>= maybe (return ()) (re . f)

              _ <- on' canvas buttonPressEvent $ tryEvent $ compCoords eventCoordinates $ \(p, d) -> (Click p, d)
              _ <- on' canvas buttonReleaseEvent $ tryEvent $ compCoords eventCoordinates $ \(p, d) -> (Release p, d)
              _ <- on' canvas enterNotifyEvent $ tryEvent $ compCoords eventCoordinates $ \(p, d) -> (MouseEnter p, d)
              _ <- on' canvas leaveNotifyEvent $ tryEvent $ compCoords eventCoordinates $ \(p, d) -> (MouseLeave p, d)
              _ <- on' canvas motionNotifyEvent $ tryEvent $ compCoords eventCoordinates $ \(p, d) -> (MoveTo p, d)
              on' canvas scrollEvent $ tryEvent $ do
                dir <- eventScrollDirection
                let tr _ = Horizontal -- TODO
                compCoords eventCoordinates $ \(p, d) -> (ScrollTo (tr dir) p, d)

          case keyh of
            Nothing -> return ()
            Just keyh -> do
                _ <- reg (\k -> keyh k >> return ()) $ \re ->
                  on' canvas keyPressEvent $ tryEvent $ do
                    m <- eventModifier
                    c <- eventKeyVal
                    kn <- lift $ keyvalName c
                    kc <- lift $ keyvalToChar c
                    liftIO $ re $ trKey m kn kc
                return ()

          _ <- liftIO' $ on canvas exposeEvent $ tryEvent $ liftIO $ do
                d <- readMVar cur'
                case d of
                    Just x -> putMVar v x
                    _ -> return ()

          canvasDraw' <- liftIO' $ do
            v2 <- newMVar False
            _ <- forkIO $ do
              threadDelay 200000
              forever $ do
                threadDelay 10000
                dia <- takeMVar v
                _ <- swapMVar cur' $ Just dia
                _ <- swapMVar v2 True
                let d = diaFun dia
                post $ canvasDraw d
                _ <- swapMVar v2 False
                return ()
            return $ \dia -> do
                b <- readMVar v2
                unless b $ do
                    _ <- tryTakeMVar v
                    putMVar v dia

          ger nhd r canvasDraw'
          return' af

        Button s sens col m -> do
            w <- liftIO'' buttonNew
            hd <- reg m $ \re -> on' w buttonActivated $ re ()
            ger hd s $ buttonSetLabel w
            ger hd sens $ widgetSetSensitive w
            let tr col = case toSRGB col of RGB r g b -> Color (f r) (f g) (f b)
                f d = fromInteger $ min 65535 $ max 0 $ floor $ d * 65536
            case col of
                Nothing -> return ()
                Just col -> ger hd col $ \c -> do
                    widgetModifyBg w StateNormal $ tr c
                    widgetModifyBg w StatePrelight $ tr c
            return' w
        Entry _ (r, s) -> do        -- TODO: red background if not ok
            w <- liftIO'' entryNew
            hd <- reg s $ \re -> on' w entryActivate $ entryGetText w >>= re
            hd' <- reg s $ \re -> on' w focusOutEvent $ lift $ entryGetText w >>= re >> return False
            ger (\x -> hd x >> hd' x) r $ entrySetText w
            return' w
        Checkbox (r, s) -> do
            w <- liftIO'' checkButtonNew
            hd <- reg s $ \re -> on' w toggled $ toggleButtonGetActive w >>= re
            ger hd r $ toggleButtonSetActive w
            return' w
        Scale a b c (r, s) -> do
            w <- liftIO'' $ hScaleNewWithRange a b c
            _ <- liftIO'' $ w `onSizeRequest` return (Requisition 200 40)
            hd <- reg s $ \re -> on' w valueChanged $ rangeGetValue w >>= re
            ger hd r $ rangeSetValue w
            return' w
        Combobox ss (r, s) -> do
            w <- liftIO'' comboBoxNewText
            _ <- liftIO'' $ w `onSizeRequest` return (Requisition 100 30)
            liftIO'' $ flip mapM_ ss $ comboBoxAppendText w
            hd <- reg s $ \re -> on' w changed $ fmap (max 0) (comboBoxGetActive w) >>= re
            ger hd r $ comboBoxSetActive w
            return' w
        List o xs -> do
            ws <- mapM toWidget xs
            w <- liftIO'' $ case o of
                Vertical -> fmap castToBox $ vBoxNew False 1
                Horizontal -> fmap castToBox $ hBoxNew False 1
            shs <- forM ws $ liftIO'' . containerAdd'' w . snd
            liftM (mapFst (sequence_ shs >>)) $ return'' ws w
        Notebook' s xs -> do
            ws <- mapM (toWidget . snd) xs
            w <- liftIO'' notebookNew
            forM_ (zip ws xs) $ \(ww, (s, _)) -> do
                liftIO'' . flip (notebookAppendPage w) s $ snd $ ww
            _ <- reg s $ \re -> on' w switchPage $ re
            return'' ws w
        Cell onCh f -> do
            let b = False
            w <- liftIO'' $ case b of
                True -> fmap castToContainer $ hBoxNew False 1
                False -> fmap castToContainer $ alignmentNew 0 0 1 1
            sh <- liftIO' $ newMVar $ return ()
            _ <- onChange onCh $ \bv -> do
                mx <- f toWidget bv
                return $ mx >>= \(x,y) -> liftIO'' $ do 
                    _ <- swapMVar sh x
                    containerForeach w $ if b then widgetHideAll else containerRemove w 
                    post' $ post $ do
                        ch <- containerGetChildren w
                        when (y `notElem` ch) $ containerAdd w y
                        x
            liftM (mapFst (join (readMVar sh) >>)) $ return'' [] w

on' :: GObjectClass x => x -> Signal x c -> c -> IO (RegionStatusChange -> IO ())
on' o s c = liftM (flip f) $ on o s c where
    f Kill = signalDisconnect
    f Block = signalBlock
    f Unblock = signalUnblock

return' :: Monad m => WidgetClass x => x -> m SWidget
return' w = return (widgetShowAll w, castToWidget w)

return'' :: Monad m => WidgetClass x => [SWidget] -> x -> m SWidget
return'' ws w = return (mapM_ fst ws >> widgetShow w, castToWidget w)

mapFst f (a, b) = (f a, b)

containerAdd'' w x = do
    a <- alignmentNew 0 0 0 0
    containerAdd a x
    containerAdd w a
    set w [ boxChildPacking a := PackNatural ]
    return $ widgetShow a

trKey mods name ch
    = ModifiedKey (Gtk.Shift `elem` mods) (Gtk.Control `elem` mods) (Gtk.Alt `elem` mods) (Gtk.Super `elem` mods) k
  where
    k = case ch of
        Just c -> Key'Char c
        _ -> case name of
            "Escape" -> Key'Escape
            "BackSpace" -> Key'Backspace
            "Insert" -> Key'Insert
            "Delete" -> Key'Delete
            "Right" -> Key'Right
            "Left" -> Key'Left
            "Down" -> Key'Down
            "Up" -> Key'Up
            "PageUp" -> Key'PageUp
            "PageDown" -> Key'PageDown
            "Home" -> Key'Home
            "End" -> Key'End
            "Return" -> Key'Char '\n'
            "Tab" -> Key'Char '\t'
            _ -> Key'Unknown