-- |This module provides a GTK+-based UI backend.
module Graphics.UI.Grapefruit.GTK (

    GTK (GTK)

) where

    {-FIXME:
        Originally, this module only contained the declaration of GTK. Unfortunately, GHC 7 did not
        (re-)export the instances from the backend modules, possibly because it has a bug regarding
        the interplay of orphan modules and mutually dependent modules. As a result, we copied the
        contents of all other modules into this module. :-(
    -}

    -- Prelude
    import Prelude hiding (sequence_, mapM_)

    -- Control
    import Control.Monad             as Monad hiding (sequence_, mapM_)
    import Control.Monad.Trans.Class as MonadTrans
    import Control.Arrow             as Arrow

    -- Data
    import Data.Foldable              as Foldable
    import Data.Sequence              as Seq      hiding (reverse, zipWith)
    import Data.Set                   as Set
    import Data.Fraction              as Fraction
    import Data.Colour.RGBSpace       as RGBSpace
    import Data.IORef                 as IORef
    import Data.Record                as Record
    import Data.Record.Optionality    as OptRecord
    import Data.Record.Signal         as SignalRecord
    import Data.Record.Signal.Context as ContextSignalRecord

    -- FRP.Grapefruit
    import FRP.Grapefruit.Setup                       as Setup
    import FRP.Grapefruit.Circuit                     as Circuit
    import FRP.Grapefruit.Signal                      as Signal
    import FRP.Grapefruit.Signal.Discrete             as DSignal
    import FRP.Grapefruit.Signal.Segmented            as SSignal
    import FRP.Grapefruit.Signal.Incremental          as ISignal    hiding (const)
    import FRP.Grapefruit.Signal.Incremental.Sequence as SeqISignal hiding (reverse)
    import FRP.Grapefruit.Signal.Incremental.Set      as SetISignal hiding (Diff)

    -- Graphics.UI.Grapefruit
    import Graphics.UI.Grapefruit.Comp              as UIComp
    import Graphics.UI.Grapefruit.Item              as UIItem
    import Graphics.UI.Grapefruit.Backend           as UIBackend
    import Graphics.UI.Grapefruit.Backend.Basic     as BasicUIBackend
    import Graphics.UI.Grapefruit.Backend.Container as ContainerUIBackend

    -- System.Glib
    import qualified System.Glib.GObject    as Glib
    import qualified System.Glib.Signals    as Glib
    import qualified System.Glib.Attributes as Glib

    -- Graphics.UI.Gtk
    import qualified Graphics.UI.Gtk as Gtk

    {-|
        Denotes the GTK+-based UI backend.

        See the documentation of "Graphics.UI.Grapefruit.Backend" for an introduction to UI
        backends.
    -}
    data GTK = GTK

    instance UIBackend GTK where

        type WidgetPlacement GTK = Gtk.Widget -> IO ()

        type WindowPlacement GTK = Gtk.Window -> IO ()

        initialize GTK = Gtk.unsafeInitGUIForThreadedRTS >> return ()

        handleEvents GTK = Gtk.mainGUI

        requestQuitting GTK = Gtk.mainQuit

        finalize GTK = return ()

        topLevel GTK = const (return ())

    instance BasicUIBackend GTK where

        label = widgetBrick (Gtk.labelNew (Nothing :: Maybe String))
                            Gtk.toWidget
                            (X :& Text := attrConsumer Gtk.labelLabel)
                            X

        pushButton = widgetBrick Gtk.buttonNew
                                 Gtk.toWidget
                                 (X :& Text := attrConsumer Gtk.buttonLabel)
                                 (X :& Push := eventProducer Gtk.buttonActivated)

        lineEditor = widgetBrick Gtk.entryNew
                                 Gtk.toWidget
                                 X
                                 (X :& Content := attrEventProducer Gtk.entryText
                                                                    Gtk.editableChanged)

        box orientation = widgetBox (case orientation of
                                         Horizontal -> newGtkBox Gtk.hBoxNew
                                         Vertical   -> newGtkBox Gtk.vBoxNew)
                                    Gtk.toWidget
                                    Gtk.containerAdd
                                    X
                                    X

        window = windowBox Gtk.windowNew
                           Gtk.toWindow
                           Gtk.containerAdd
                           (X :& Title   := attrConsumer Gtk.windowTitle)
                           (X :& Closure := eventProducer plainDeleteEvent)

    newGtkBox :: (Gtk.BoxClass gtkBox) => (Bool -> Int -> IO gtkBox) -> IO Gtk.Box
    newGtkBox rawNewGtkBox = fmap Gtk.toBox (rawNewGtkBox False 0)

    plainDeleteEvent :: Gtk.WidgetClass self => Gtk.Signal self (IO ())
    plainDeleteEvent = Gtk.Signal impl' where

        impl' bool object handler = impl bool object handler' where

            handler' = lift handler >> return False

        Gtk.Signal impl = Gtk.deleteEvent

    instance ContainerUIBackend GTK where

        listView = listViewBrick id id

        setView = listViewBrick SetISignal.toSeqs (Set.fromList . Foldable.toList)

        data Cell GTK display = forall gtkCellRenderer. (Gtk.CellRendererClass gtkCellRenderer) =>
                                Cell (IO gtkCellRenderer) [CellValAttr gtkCellRenderer display]

        textCell = Cell Gtk.cellRendererTextNew [textAttr,backgroundColorAttr] where

            textAttr                                      = CellValAttr toText Gtk.cellText

            toText (TextCellDisplay text _)               = text

            backgroundColorAttr                           = CellValAttr toBackgroundColor
                                                                        Gtk.cellTextBackgroundColor

            toBackgroundColor (TextCellDisplay _ bgColor) = toGtkColor bgColor

        progressCell = Cell Gtk.cellRendererProgressNew [valueAttr,textAttr] where

            valueAttr                                = CellValAttr toValue Gtk.cellProgressValue

            toValue (ProgressCellDisplay progress _) = round (Fraction.toPercentage progress)

            textAttr                                 = CellValAttr toText Gtk.cellProgressText

            toText (ProgressCellDisplay _ maybeText) = maybeText

    data CellValAttr gtkCellRenderer display = forall gtkReadVal gtkWriteVal.
                                               CellValAttr (display -> gtkWriteVal)
                                                           (Gtk.ReadWriteAttr gtkCellRenderer
                                                                              gtkReadVal
                                                                              gtkWriteVal)

    listViewBrick :: (forall era. ISignal era container -> ISignal era (Seq el))
                  -> (Seq el -> container)
                  -> Brick Widget
                           GTK
                           (X :& Req Elements      ::: ISignal `Of` container
                              :& Req Columns       ::: ISignal `Of` Seq (Column GTK el)
                              :& Opt HasScrollbars ::: SSignal `Of` (Orientation -> Availability))
                           (X :&     Selection ::: SSignal `Of` container)
    listViewBrick fromContainerSignal toContainer = brick where

        brick = widgetBrick (do
                                 gtkScrolledWindow <- Gtk.scrolledWindowNew Nothing Nothing
                                 gtkTreeView <- Gtk.treeViewNew
                                 Gtk.containerAdd gtkScrolledWindow gtkTreeView
                                 gtkTreeSelection <- Gtk.treeViewGetSelection gtkTreeView
                                 Gtk.treeSelectionSetMode gtkTreeSelection Gtk.SelectionMultiple
                                 gtkListStore <- Gtk.listStoreNew []
                                 seqRef <- newIORef Seq.empty
                                 Gtk.treeViewSetModel gtkTreeView gtkListStore
                                 return (gtkScrolledWindow,gtkTreeView,gtkListStore,seqRef))
                            (\(gtkScrolledWindow,_,_,_) -> Gtk.toWidget gtkScrolledWindow)
                            (X :& Elements      := consumerComap fromContainerSignal .
                                                   seqSignalConsumer
                                                       (withModelAndRef insertListViewElement)
                                                       (withModelAndRef deleteListViewElement)
                                                       (withModelAndRef shiftListViewElement)
                               :& Columns       := seqSignalConsumer
                                                       (withViewAndModel insertListViewColumn)
                                                       (withView         deleteListViewColumn)
                                                       (withView         shiftListViewColumn)
                               :& HasScrollbars := withScrolledWindow hasScrollbarsConsumer)
                            (X :& Selection := producerMap (fmap toContainer) .
                                               withViewAndModel selectionProducer) where

        withScrolledWindow fun (gtkScrolledWindow,_,_,_) = fun gtkScrolledWindow

        withViewAndModel :: (Gtk.TreeView -> Gtk.ListStore el -> result)
                         -> (Gtk.ScrolledWindow,Gtk.TreeView,Gtk.ListStore el,IORef (Seq el))
                         -> result
        withViewAndModel fun (_,gtkTreeView,gtkListStore,_) = fun gtkTreeView gtkListStore

        withView :: (Gtk.TreeView -> result)
                 -> (Gtk.ScrolledWindow,Gtk.TreeView,Gtk.ListStore el,IORef (Seq el))
                 -> result
        withView fun = withViewAndModel (const . fun)

        withModelAndRef :: (Gtk.ListStore el -> IORef (Seq el) -> result)
                        -> (Gtk.ScrolledWindow,Gtk.TreeView,Gtk.ListStore el,IORef (Seq el))
                        -> result
        withModelAndRef fun (_,_,gtkListStore,seqRef) = fun gtkListStore seqRef

    consumerComap :: (forall era. signal era val -> signal' era val')
                  -> (Consumer signal' val' -> Consumer signal val)
    consumerComap signalFun consumer' = Consumer $ arr signalFun >>> Signal.consume consumer'

    producerMap :: (forall era. signal era val -> signal' era val')
                -> (Producer signal val -> Producer signal' val')
    producerMap signalFun producer = Producer $ Signal.produce producer >>> arr signalFun

    insertListViewElement :: Gtk.ListStore el -> IORef (Seq el) -> Int -> el -> IO ()
    insertListViewElement gtkListStore seqRef idx el = Gtk.listStoreInsert gtkListStore idx el >>
                                                       modifyIORef seqRef (flip patch diff) where

        diff = SeqISignal.elementInsertion idx el

    deleteListViewElement :: Gtk.ListStore el -> IORef (Seq el) -> Int -> IO ()
    deleteListViewElement gtkListStore seqRef idx = Gtk.listStoreRemove gtkListStore idx >>
                                                    modifyIORef seqRef (flip patch diff) where

        diff = SeqISignal.elementDeletion idx

    shiftListViewElement :: Gtk.ListStore el -> IORef (Seq el) -> Int -> Int -> IO ()
    shiftListViewElement gtkListStore seqRef from to = shift where

        shift = do
                    seq <- readIORef seqRef
                    Gtk.listStoreRemove gtkListStore from
                    Gtk.listStoreInsert gtkListStore to (Seq.index seq from)
                    modifyIORef seqRef (flip patch diff)

        diff  = elementShift from to

    insertListViewColumn :: Gtk.TreeView -> Gtk.ListStore el -> Int -> Column GTK el -> IO ()
    insertListViewColumn gtkTreeView
                         gtkListStore
                         idx
                         (Column title toDisplay (Cell newCellRenderer cellValAttrs)) = insert where

        insert                    = do
                                        gtkTreeViewColumn <- Gtk.treeViewColumnNew
                                        Gtk.treeViewColumnSetTitle gtkTreeViewColumn title
                                        gtkCellRenderer <- newCellRenderer
                                        Gtk.cellLayoutPackStart gtkTreeViewColumn
                                                                gtkCellRenderer
                                                                True
                                        Gtk.cellLayoutSetAttributes gtkTreeViewColumn
                                                                    gtkCellRenderer
                                                                    gtkListStore
                                                                    (mapM cellValAss cellValAttrs)
                                        Gtk.treeViewInsertColumn gtkTreeView gtkTreeViewColumn idx
                                        return ()

        cellValAss cellValAttr el = case cellValAttr of
                                        CellValAttr toWriteVal
                                                    gtkWriteAttr -> gtkWriteAttr Gtk.:=
                                                                    toWriteVal (toDisplay el)

    deleteListViewColumn :: Gtk.TreeView -> Int -> IO ()
    deleteListViewColumn gtkTreeView idx = delete where

        delete = do
                     Just gtkTreeViewColumn <- Gtk.treeViewGetColumn gtkTreeView idx
                     Gtk.treeViewRemoveColumn gtkTreeView gtkTreeViewColumn
                     return ()

    shiftListViewColumn :: Gtk.TreeView -> Int -> Int -> IO ()
    shiftListViewColumn gtkTreeView from to = shift where

        shift                    = do
                                       Just gtkFromColumn <- Gtk.treeViewGetColumn gtkTreeView from
                                       if to == 0 then Gtk.treeViewMoveColumnFirst gtkTreeView
                                                                                   gtkFromColumn
                                                  else if from <= to
                                                           then shiftAfter gtkFromColumn to
                                                           else shiftAfter gtkFromColumn (pred to)

        shiftAfter gtkColumn idx = do
                                       Just gtkBeforeColumn <- Gtk.treeViewGetColumn gtkTreeView idx
                                       Gtk.treeViewMoveColumnAfter gtkTreeView
                                                                   gtkColumn
                                                                   gtkBeforeColumn

    seqSignalConsumer :: (gtkObject -> Int -> el -> IO ())
                      -> (gtkObject -> Int -> IO ())
                      -> (gtkObject -> Int -> Int -> IO ())
                      -> gtkObject
                      -> Consumer ISignal (Seq el)
    seqSignalConsumer insertOne deleteOne shiftOne gtkObject = consumer where

        consumer                              = ISignal.consumer (insert 0) patchObject

        patchObject (Diff atomicDiffs)        = mapM_ atomicPatchObject atomicDiffs

        atomicPatchObject (Insertion idx seq) = insert idx seq
        atomicPatchObject (Deletion idx cnt)  = delete idx cnt
        atomicPatchObject (Shift from cnt to) = let

                                                    oneShifts = zipWith (shiftOne gtkObject)
                                                                        [from..pred (from + cnt)]
                                                                        [to..pred (to + cnt)]

                                                in sequence_ (if from <= to then reverse oneShifts
                                                                            else oneShifts)
        atomicPatchObject (Update idx seq)    = delete idx (Seq.length seq) >> insert idx seq

        insert idx seq                        = zipWithM_ (insertOne gtkObject)
                                                          [idx..]
                                                          (Foldable.toList seq)

        delete idx cnt                        = replicateM_ cnt (deleteOne gtkObject idx)

    hasScrollbarsConsumer :: Gtk.ScrolledWindow -> Consumer SSignal (Orientation -> Availability)
    hasScrollbarsConsumer gtkScrolledWindow = SSignal.consumer hdlr where

        hdlr avails          = Gtk.scrolledWindowSetPolicy gtkScrolledWindow
                                                           (policy avails Horizontal)
                                                           (policy avails Vertical)

        policy avails orient = case avails orient of
                                   Never       -> Gtk.PolicyNever
                                   AsNecessary -> Gtk.PolicyAutomatic
                                   Always      -> Gtk.PolicyAlways

    selectionProducer :: Gtk.TreeView -> Gtk.ListStore el -> Producer SSignal (Seq el)
    selectionProducer gtkTreeView gtkListStore = Producer $ proc _ -> do
        gtkTreeSelection <- act -< Gtk.treeViewGetSelection gtkTreeView
        let

            actualProducer = readEventProducer (readSelection gtkListStore)
                                               Gtk.treeSelectionSelectionChanged
                                               gtkTreeSelection

        Signal.produce $ actualProducer -<< ()

    readSelection :: Gtk.ListStore el -> Gtk.TreeSelection -> IO (Seq el)
    readSelection gtkListStore gtkTreeSelection = read where

        read = do
                   gtkSelPaths <- Gtk.treeSelectionGetSelectedRows gtkTreeSelection
                   els <- mapM (Gtk.listStoreGetValue gtkListStore)
                               (Prelude.map treePathToIndex gtkSelPaths)
                   return (Seq.fromList els)

    treePathToIndex :: Gtk.TreePath -> Int
    treePathToIndex [idx] = idx
    treePathToIndex _     = error "grapefruit-ui-gtk: tree path has not length 1"

    -- FIXME: This should maybe go to another place.
    toGtkColor :: RGB Fraction -> Gtk.Color
    toGtkColor (RGB redFrac greenFrac blueFrac) = Gtk.Color (toWord16 redFrac)
                                                            (toWord16 greenFrac)
                                                            (toWord16 blueFrac) where

        toWord16 = round . toNumber (0,0xFFFF)

    -- |Constructs a GTK+-based widget brick.
    widgetBrick :: (OptRecord iOptRecord,
                    Record SignalKind (All iOptRecord),
                    Record SignalKind oRecord)
                => IO nativeWidget
                   -- ^an action which creates a native widget
                -> (nativeWidget -> Gtk.Widget)
                   -- ^converts a native widget into a Gtk2Hs widget
                -> ContextConsumerRecord nativeWidget (All iOptRecord)
                   -- ^consumers of those inputs which are specific to this brick
                -> ContextProducerRecord nativeWidget oRecord
                   -- ^producers of those outputs which are specific to this brick
                -> Brick Widget GTK iOptRecord oRecord
    widgetBrick = brickOrBox brick commonWidgetConsumerRecord commonWidgetProducerRecord

    -- |Constructs a GTK+-based window brick.
    windowBrick :: (OptRecord iOptRecord,
                    Record SignalKind (All iOptRecord),
                    Record SignalKind oRecord)
                => IO nativeWindow
                   -- ^an action which creates a native window
                -> (nativeWindow -> Gtk.Window)
                   -- ^converts a native window into a Gtk2Hs window
                -> ContextConsumerRecord nativeWindow (All iOptRecord)
                   -- ^consumers of those inputs which are specific to this brick
                -> ContextProducerRecord nativeWindow oRecord
                   -- ^producers of those outputs which are specific to this brick
                -> Brick Window GTK iOptRecord oRecord
    windowBrick = brickOrBox brick commonWindowConsumerRecord commonWindowProducerRecord

    -- |Constructs a GTK+-based widget box.
    widgetBox :: (UIComp innerUIComp,
                  OptRecord iOptRecord,
                  Record SignalKind (All iOptRecord),
                  Record SignalKind oRecord)
              => IO nativeWidget
                 -- ^an action which creates a native widget
              -> (nativeWidget -> Gtk.Widget)
                  -- ^converts a native widget into a Gtk2Hs widget
              -> (nativeWidget -> Placement innerItem GTK)
                 -- ^conversion from a native widget into the placement for its inner items
              -> ContextConsumerRecord nativeWidget (All iOptRecord)
                 -- ^consumers of those inputs which are specific to this box
              -> ContextProducerRecord nativeWidget oRecord
                 -- ^producers of those outputs which are specific to this box
              -> Box innerUIComp innerItem Widget GTK iOptRecord oRecord
    widgetBox = brickOrBox UIItem.box commonWidgetConsumerRecord commonWidgetProducerRecord

    -- |Constructs a GTK+-based window box.
    windowBox :: (UIComp innerUIComp,
                  OptRecord iOptRecord,
                  Record SignalKind (All iOptRecord),
                  Record SignalKind oRecord)
              => IO nativeWindow
                 -- ^an action which creates a native window
              -> (nativeWindow -> Gtk.Window)
                 -- ^converts a native window into a Gtk2Hs window
              -> (nativeWindow -> Placement innerItem GTK)
                 -- ^conversion from a native window into the placement for its inner items
              -> ContextConsumerRecord nativeWindow (All iOptRecord)
                 -- ^consumers of those inputs which are specific to this box
              -> ContextProducerRecord nativeWindow oRecord
                 -- ^producers of those outputs which are specific to this box
              -> Box innerUIComp innerItem Window GTK iOptRecord oRecord
    windowBox = brickOrBox UIItem.box commonWindowConsumerRecord commonWindowProducerRecord

    brickOrBox :: (Gtk.WidgetClass gtkItem, Record SignalKind iRecord, Record SignalKind oRecord)
               => (ContextConsumerRecord nativeItem iRecord ->
                   ContextProducerRecord nativeItem oRecord ->
                   (nativeItem -> IO ())                    ->
                   ((gtkItem -> IO ()) -> IO nativeItem)    ->
                   result)
               -> ContextConsumerRecord gtkItem iRecord
               -> ContextProducerRecord gtkItem oRecord
               -> IO nativeItem
               -> (nativeItem -> gtkItem)
               -> result
    brickOrBox genericBrickOrBox
               contextConsumers
               contextProducers
               newNativeItem
               toGtkItem         = genericBrickOrBox (Record.map (brickOrBoxTransformer toGtkItem)
                                                                 contextConsumers)
                                                     (Record.map (brickOrBoxTransformer toGtkItem)
                                                                 contextProducers)
                                                     (Gtk.widgetShowAll . toGtkItem)
                                                     {-FIXME:
                                                         Using widgetShowAll instead of widgetShow
                                                         is just a temporary hack for supporting
                                                         tree views inside scrolled windows.
                                                     -}
                                                     newItem where

        newItem placement = do
                                nativeItem <- newNativeItem
                                placement (toGtkItem nativeItem)
                                return nativeItem

    brickOrBoxTransformer :: (nativeItem -> gtkItem)
                          -> Forall SignalKind
                                    (TransformerPiece (ContextConnectorStyle gtkItem connector)
                                                      (ContextConnectorStyle nativeItem connector))
    brickOrBoxTransformer toGtkItem = SignalForall (TransformerPiece (. toGtkItem))

    commonWidgetConsumerRecord :: ContextConsumerRecord Gtk.Widget
                                                        (All (CommonInputOptRecord Widget))
    commonWidgetConsumerRecord = X :& IsEnabled := SSignal.consumer . Gtk.widgetSetSensitivity

    commonWidgetProducerRecord :: ContextProducerRecord Gtk.Widget (CommonOutputRecord Window)
    commonWidgetProducerRecord = X

    commonWindowConsumerRecord :: ContextConsumerRecord Gtk.Window
                                                        (All (CommonInputOptRecord Window))
    commonWindowConsumerRecord = X

    commonWindowProducerRecord :: ContextProducerRecord Gtk.Window (CommonOutputRecord Window)
    commonWindowProducerRecord = X

    {-|
        Constructs a consumer of segmented signals which makes a Gtk2Hs attribute of a Gtk2Hs widget
        being updated on every update point of the consumed signal.
    -}
    attrConsumer :: (Glib.GObjectClass gObject)
                 => Glib.ReadWriteAttr gObject readVal writeVal
                 -> gObject
                 -> Consumer SSignal writeVal
    attrConsumer gAttr gObject = SSignal.consumer $ \val -> Glib.set gObject [gAttr Glib.:= val]

    -- |Constructs a producer of discrete signals that represent sequences of Gtk2Hs events.
    eventProducer :: (Glib.GObjectClass gObject)
                   => Gtk.Signal gObject (IO ())
                      -- ^a Gtk2Hs signal
                   -> gObject
                      -- ^a Gtk2Hs widget which provides the events
                   -> Producer DSignal ()
    eventProducer gtkSignal gObject = DSignal.producer
                                          (register (flip Gtk.on gtkSignal) gObject . ($ ()))

    {-|
        Constructs a producer of segmented signals whose values can be read with a certain I/O
        action and which are updated updated on certain Gtk2Hs events.
    -}
    readEventProducer :: (Glib.GObjectClass gObject)
                      => (gObject -> IO val)
                         -- ^an action which provides the current value of the produced signal
                      -> Gtk.Signal gObject (IO ())
                         -- ^a Gtk2Hs signal
                      -> gObject
                         -- ^a Gtk2Hs widget
                      -> Producer SSignal val
    readEventProducer readVal gtkSignal gObject = SSignal.producer
                                                    (readVal gObject)
                                                    (register (flip Gtk.on gtkSignal) gObject)

    {-|
        Constructs a producer of segmented signals that reflect a Gtk2Hs attribute and are updated
        on certain Gtk2Hs events.
    -}
    attrEventProducer :: (Glib.GObjectClass gObject)
                      => Glib.ReadWriteAttr gObject readVal writeVal
                         -- ^a Gtk2Hs attribute providing the values of the produced signal
                      -> Gtk.Signal gObject (IO ())
                         -- ^a Gtk2Hs signal
                      -> gObject
                         -- ^a Gtk2Hs widget
                      -> Producer SSignal readVal
    attrEventProducer gAttr = readEventProducer (flip Glib.get gAttr)

    register :: (Glib.GObjectClass gObject)
             => (gObject -> IO () -> IO (Glib.ConnectId gObject))
             -> gObject
             -> (IO () -> Setup)
    register onEvent gObject handler = setup $ do
                                                   connectID <- onEvent gObject handler
                                                   return (Glib.signalDisconnect connectID)