module Graphics.UI.Grapefruit.GTK (
GTK (GTK)
) where
import Prelude hiding (sequence_, mapM_)
import Control.Monad as Monad hiding (sequence_, mapM_)
import Control.Monad.Trans.Class as MonadTrans
import Control.Arrow as Arrow
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
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)
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
import qualified System.Glib.GObject as Glib
import qualified System.Glib.Signals as Glib
import qualified System.Glib.Attributes as Glib
import qualified Graphics.UI.Gtk as Gtk
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"
toGtkColor :: RGB Fraction -> Gtk.Color
toGtkColor (RGB redFrac greenFrac blueFrac) = Gtk.Color (toWord16 redFrac)
(toWord16 greenFrac)
(toWord16 blueFrac) where
toWord16 = round . toNumber (0,0xFFFF)
widgetBrick :: (OptRecord iOptRecord,
Record SignalKind (All iOptRecord),
Record SignalKind oRecord)
=> IO nativeWidget
-> (nativeWidget -> Gtk.Widget)
-> ContextConsumerRecord nativeWidget (All iOptRecord)
-> ContextProducerRecord nativeWidget oRecord
-> Brick Widget GTK iOptRecord oRecord
widgetBrick = brickOrBox brick commonWidgetConsumerRecord commonWidgetProducerRecord
windowBrick :: (OptRecord iOptRecord,
Record SignalKind (All iOptRecord),
Record SignalKind oRecord)
=> IO nativeWindow
-> (nativeWindow -> Gtk.Window)
-> ContextConsumerRecord nativeWindow (All iOptRecord)
-> ContextProducerRecord nativeWindow oRecord
-> Brick Window GTK iOptRecord oRecord
windowBrick = brickOrBox brick commonWindowConsumerRecord commonWindowProducerRecord
widgetBox :: (UIComp innerUIComp,
OptRecord iOptRecord,
Record SignalKind (All iOptRecord),
Record SignalKind oRecord)
=> IO nativeWidget
-> (nativeWidget -> Gtk.Widget)
-> (nativeWidget -> Placement innerItem GTK)
-> ContextConsumerRecord nativeWidget (All iOptRecord)
-> ContextProducerRecord nativeWidget oRecord
-> Box innerUIComp innerItem Widget GTK iOptRecord oRecord
widgetBox = brickOrBox UIItem.box commonWidgetConsumerRecord commonWidgetProducerRecord
windowBox :: (UIComp innerUIComp,
OptRecord iOptRecord,
Record SignalKind (All iOptRecord),
Record SignalKind oRecord)
=> IO nativeWindow
-> (nativeWindow -> Gtk.Window)
-> (nativeWindow -> Placement innerItem GTK)
-> ContextConsumerRecord nativeWindow (All iOptRecord)
-> ContextProducerRecord nativeWindow oRecord
-> 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)
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
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]
eventProducer :: (Glib.GObjectClass gObject)
=> Gtk.Signal gObject (IO ())
-> gObject
-> Producer DSignal ()
eventProducer gtkSignal gObject = DSignal.producer
(register (flip Gtk.on gtkSignal) gObject . ($ ()))
readEventProducer :: (Glib.GObjectClass gObject)
=> (gObject -> IO val)
-> Gtk.Signal gObject (IO ())
-> gObject
-> Producer SSignal val
readEventProducer readVal gtkSignal gObject = SSignal.producer
(readVal gObject)
(register (flip Gtk.on gtkSignal) gObject)
attrEventProducer :: (Glib.GObjectClass gObject)
=> Glib.ReadWriteAttr gObject readVal writeVal
-> Gtk.Signal gObject (IO ())
-> gObject
-> 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)