-- |This module provides a GTK+-based UI backend.moduleGraphics.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. :-(
-}-- PreludeimportPreludehiding(sequence_,mapM_)-- ControlimportControl.MonadasMonadhiding(sequence_,mapM_)importControl.ArrowasArrow-- DataimportData.FoldableasFoldableimportData.SequenceasSeqhiding(reverse,zipWith)importData.SetasSetimportData.FractionasFractionimportData.Colour.RGBSpaceasRGBSpaceimportData.IORefasIORefimportData.RecordasRecordimportData.Record.OptionalityasOptRecordimportData.Record.SignalasSignalRecordimportData.Record.Signal.ContextasContextSignalRecord-- FRP.GrapefruitimportFRP.Grapefruit.SetupasSetupimportFRP.Grapefruit.CircuitasCircuitimportFRP.Grapefruit.SignalasSignalimportFRP.Grapefruit.Signal.DiscreteasDSignalimportFRP.Grapefruit.Signal.SegmentedasSSignalimportFRP.Grapefruit.Signal.IncrementalasISignalhiding(const)importFRP.Grapefruit.Signal.Incremental.SequenceasSeqISignalhiding(reverse)importFRP.Grapefruit.Signal.Incremental.SetasSetISignalhiding(Diff)-- Graphics.UI.GrapefruitimportGraphics.UI.Grapefruit.CompasUICompimportGraphics.UI.Grapefruit.ItemasUIItemimportGraphics.UI.Grapefruit.BackendasUIBackendimportGraphics.UI.Grapefruit.Backend.BasicasBasicUIBackendimportGraphics.UI.Grapefruit.Backend.ContainerasContainerUIBackend-- System.GlibimportqualifiedSystem.Glib.GObjectasGlibimportqualifiedSystem.Glib.SignalsasGlibimportqualifiedSystem.Glib.AttributesasGlib-- Graphics.UI.GtkimportqualifiedGraphics.UI.GtkasGtk{-|
Denotes the GTK+-based UI backend.
See the documentation of "Graphics.UI.Grapefruit.Backend" for an introduction to UI
backends.
-}dataGTK=GTKinstanceUIBackendGTKwheretypeWidgetPlacementGTK=Gtk.Widget->IO()typeWindowPlacementGTK=Gtk.Window->IO()initializeGTK=Gtk.unsafeInitGUIForThreadedRTS>>return()handleEventsGTK=Gtk.mainGUIrequestQuittingGTK=Gtk.mainQuitfinalizeGTK=return()topLevelGTK=const(return())instanceBasicUIBackendGTKwherelabel=widgetBrick(Gtk.labelNewNothing)Gtk.toWidget(X:&Text:=attrConsumerGtk.labelLabel)XpushButton=widgetBrickGtk.buttonNewGtk.toWidget(X:&Text:=attrConsumerGtk.buttonLabel)(X:&Push:=eventProducerGtk.onPressed)lineEditor=widgetBrickGtk.entryNewGtk.toWidgetX(X:&Content:=attrEventProducerGtk.entryTextGtk.onEditableChanged)boxorientation=widgetBox(caseorientationofHorizontal->newGtkBoxGtk.hBoxNewVertical->newGtkBoxGtk.vBoxNew)Gtk.toWidgetGtk.containerAddXXwindow=windowBoxGtk.windowNewGtk.toWindowGtk.containerAdd(X:&Title:=attrConsumerGtk.windowTitle)(X:&Closure:=eventProducerGtk.onDestroy)newGtkBox::(Gtk.BoxClassgtkBox)=>(Bool->Int->IOgtkBox)->IOGtk.BoxnewGtkBoxrawNewGtkBox=fmapGtk.toBox(rawNewGtkBoxFalse0)instanceContainerUIBackendGTKwherelistView=listViewBrickididsetView=listViewBrickSetISignal.toSeqs(Set.fromList.Foldable.toList)dataCellGTKdisplay=forallgtkCellRenderer.(Gtk.CellRendererClassgtkCellRenderer)=>Cell(IOgtkCellRenderer)[CellValAttrgtkCellRendererdisplay]textCell=CellGtk.cellRendererTextNew[textAttr,backgroundColorAttr]wheretextAttr=CellValAttrtoTextGtk.cellTexttoText(TextCellDisplaytext_)=textbackgroundColorAttr=CellValAttrtoBackgroundColorGtk.cellTextBackgroundColortoBackgroundColor(TextCellDisplay_bgColor)=toGtkColorbgColorprogressCell=CellGtk.cellRendererProgressNew[valueAttr,textAttr]wherevalueAttr=CellValAttrtoValueGtk.cellProgressValuetoValue(ProgressCellDisplayprogress_)=round(Fraction.toPercentageprogress)textAttr=CellValAttrtoTextGtk.cellProgressTexttoText(ProgressCellDisplay_maybeText)=maybeTextdataCellValAttrgtkCellRendererdisplay=forallgtkReadValgtkWriteVal.CellValAttr(display->gtkWriteVal)(Gtk.ReadWriteAttrgtkCellRenderergtkReadValgtkWriteVal)listViewBrick::(forallera.ISignaleracontainer->ISignalera(Seqel))->(Seqel->container)->BrickWidgetGTK(X:&ReqElements:::ISignal`Of`container:&ReqColumns:::ISignal`Of`Seq(ColumnGTKel):&OptHasScrollbars:::SSignal`Of`(Orientation->Availability))(X:&Selection:::SSignal`Of`container)listViewBrickfromContainerSignaltoContainer=brickwherebrick=widgetBrick(dogtkScrolledWindow<-Gtk.scrolledWindowNewNothingNothinggtkTreeView<-Gtk.treeViewNewGtk.containerAddgtkScrolledWindowgtkTreeViewgtkTreeSelection<-Gtk.treeViewGetSelectiongtkTreeViewGtk.treeSelectionSetModegtkTreeSelectionGtk.SelectionMultiplegtkListStore<-Gtk.listStoreNew[]seqRef<-newIORefSeq.emptyGtk.treeViewSetModelgtkTreeViewgtkListStorereturn(gtkScrolledWindow,gtkTreeView,gtkListStore,seqRef))(\(gtkScrolledWindow,_,_,_)->Gtk.toWidgetgtkScrolledWindow)(X:&Elements:=consumerComapfromContainerSignal.seqSignalConsumer(withModelAndRefinsertListViewElement)(withModelAndRefdeleteListViewElement)(withModelAndRefshiftListViewElement):&Columns:=seqSignalConsumer(withViewAndModelinsertListViewColumn)(withViewdeleteListViewColumn)(withViewshiftListViewColumn):&HasScrollbars:=withScrolledWindowhasScrollbarsConsumer)(X:&Selection:=producerMap(fmaptoContainer).withViewAndModelselectionProducer)wherewithScrolledWindowfun(gtkScrolledWindow,_,_,_)=fungtkScrolledWindowwithViewAndModel::(Gtk.TreeView->Gtk.ListStoreel->result)->(Gtk.ScrolledWindow,Gtk.TreeView,Gtk.ListStoreel,IORef(Seqel))->resultwithViewAndModelfun(_,gtkTreeView,gtkListStore,_)=fungtkTreeViewgtkListStorewithView::(Gtk.TreeView->result)->(Gtk.ScrolledWindow,Gtk.TreeView,Gtk.ListStoreel,IORef(Seqel))->resultwithViewfun=withViewAndModel(const.fun)withModelAndRef::(Gtk.ListStoreel->IORef(Seqel)->result)->(Gtk.ScrolledWindow,Gtk.TreeView,Gtk.ListStoreel,IORef(Seqel))->resultwithModelAndReffun(_,_,gtkListStore,seqRef)=fungtkListStoreseqRefconsumerComap::(forallera.signaleraval->signal'eraval')->(Consumersignal'val'->Consumersignalval)consumerComapsignalFunconsumer'=Consumer$arrsignalFun>>>Signal.consumeconsumer'producerMap::(forallera.signaleraval->signal'eraval')->(Producersignalval->Producersignal'val')producerMapsignalFunproducer=Producer$Signal.produceproducer>>>arrsignalFuninsertListViewElement::Gtk.ListStoreel->IORef(Seqel)->Int->el->IO()insertListViewElementgtkListStoreseqRefidxel=Gtk.listStoreInsertgtkListStoreidxel>>modifyIORefseqRef(flippatchdiff)wherediff=SeqISignal.elementInsertionidxeldeleteListViewElement::Gtk.ListStoreel->IORef(Seqel)->Int->IO()deleteListViewElementgtkListStoreseqRefidx=Gtk.listStoreRemovegtkListStoreidx>>modifyIORefseqRef(flippatchdiff)wherediff=SeqISignal.elementDeletionidxshiftListViewElement::Gtk.ListStoreel->IORef(Seqel)->Int->Int->IO()shiftListViewElementgtkListStoreseqReffromto=shiftwhereshift=doseq<-readIORefseqRefGtk.listStoreRemovegtkListStorefromGtk.listStoreInsertgtkListStoreto(Seq.indexseqfrom)modifyIORefseqRef(flippatchdiff)diff=elementShiftfromtoinsertListViewColumn::Gtk.TreeView->Gtk.ListStoreel->Int->ColumnGTKel->IO()insertListViewColumngtkTreeViewgtkListStoreidx(ColumntitletoDisplay(CellnewCellRenderercellValAttrs))=insertwhereinsert=dogtkTreeViewColumn<-Gtk.treeViewColumnNewGtk.treeViewColumnSetTitlegtkTreeViewColumntitlegtkCellRenderer<-newCellRendererGtk.cellLayoutPackStartgtkTreeViewColumngtkCellRendererTrueGtk.cellLayoutSetAttributesgtkTreeViewColumngtkCellRenderergtkListStore(mapMcellValAsscellValAttrs)Gtk.treeViewInsertColumngtkTreeViewgtkTreeViewColumnidxreturn()cellValAsscellValAttrel=casecellValAttrofCellValAttrtoWriteValgtkWriteAttr->gtkWriteAttrGtk.:=toWriteVal(toDisplayel)deleteListViewColumn::Gtk.TreeView->Int->IO()deleteListViewColumngtkTreeViewidx=deletewheredelete=doJustgtkTreeViewColumn<-Gtk.treeViewGetColumngtkTreeViewidxGtk.treeViewRemoveColumngtkTreeViewgtkTreeViewColumnreturn()shiftListViewColumn::Gtk.TreeView->Int->Int->IO()shiftListViewColumngtkTreeViewfromto=shiftwhereshift=doJustgtkFromColumn<-Gtk.treeViewGetColumngtkTreeViewfromifto==0thenGtk.treeViewMoveColumnFirstgtkTreeViewgtkFromColumnelseiffrom<=tothenshiftAftergtkFromColumntoelseshiftAftergtkFromColumn(predto)shiftAftergtkColumnidx=doJustgtkBeforeColumn<-Gtk.treeViewGetColumngtkTreeViewidxGtk.treeViewMoveColumnAftergtkTreeViewgtkColumngtkBeforeColumnseqSignalConsumer::(gtkObject->Int->el->IO())->(gtkObject->Int->IO())->(gtkObject->Int->Int->IO())->gtkObject->ConsumerISignal(Seqel)seqSignalConsumerinsertOnedeleteOneshiftOnegtkObject=consumerwhereconsumer=ISignal.consumer(insert0)patchObjectpatchObject(DiffatomicDiffs)=mapM_atomicPatchObjectatomicDiffsatomicPatchObject(Insertionidxseq)=insertidxseqatomicPatchObject(Deletionidxcnt)=deleteidxcntatomicPatchObject(Shiftfromcntto)=letoneShifts=zipWith(shiftOnegtkObject)[from..pred(from+cnt)][to..pred(to+cnt)]insequence_(iffrom<=tothenreverseoneShiftselseoneShifts)atomicPatchObject(Updateidxseq)=deleteidx(Seq.lengthseq)>>insertidxseqinsertidxseq=zipWithM_(insertOnegtkObject)[idx..](Foldable.toListseq)deleteidxcnt=replicateM_cnt(deleteOnegtkObjectidx)hasScrollbarsConsumer::Gtk.ScrolledWindow->ConsumerSSignal(Orientation->Availability)hasScrollbarsConsumergtkScrolledWindow=SSignal.consumerhdlrwherehdlravails=Gtk.scrolledWindowSetPolicygtkScrolledWindow(policyavailsHorizontal)(policyavailsVertical)policyavailsorient=caseavailsorientofNever->Gtk.PolicyNeverAsNecessary->Gtk.PolicyAutomaticAlways->Gtk.PolicyAlwaysselectionProducer::Gtk.TreeView->Gtk.ListStoreel->ProducerSSignal(Seqel)selectionProducergtkTreeViewgtkListStore=Producer$proc_->dogtkTreeSelection<-act-<Gtk.treeViewGetSelectiongtkTreeViewletactualProducer=readEventProducer(readSelectiongtkListStore)Gtk.onSelectionChangedgtkTreeSelectionSignal.produce$actualProducer-<<()readSelection::Gtk.ListStoreel->Gtk.TreeSelection->IO(Seqel)readSelectiongtkListStoregtkTreeSelection=readwhereread=dogtkSelPaths<-Gtk.treeSelectionGetSelectedRowsgtkTreeSelectionels<-mapM(Gtk.listStoreGetValuegtkListStore)(Prelude.maptreePathToIndexgtkSelPaths)return(Seq.fromListels)treePathToIndex::Gtk.TreePath->InttreePathToIndex[idx]=idxtreePathToIndex_=error"grapefruit-ui-gtk: tree path has not length 1"-- FIXME: This should maybe go to another place.toGtkColor::RGBFraction->Gtk.ColortoGtkColor(RGBredFracgreenFracblueFrac)=Gtk.Color(toWord16redFrac)(toWord16greenFrac)(toWord16blueFrac)wheretoWord16=round.toNumber(0,0xFFFF)-- |Constructs a GTK+-based widget brick.widgetBrick::(OptRecordiOptRecord,RecordSignalKind(AlliOptRecord),RecordSignalKindoRecord)=>IOnativeWidget-- ^an action which creates a native widget->(nativeWidget->Gtk.Widget)-- ^converts a native widget into a Gtk2Hs widget->ContextConsumerRecordnativeWidget(AlliOptRecord)-- ^consumers of those inputs which are specific to this brick->ContextProducerRecordnativeWidgetoRecord-- ^producers of those outputs which are specific to this brick->BrickWidgetGTKiOptRecordoRecordwidgetBrick=brickOrBoxbrickcommonWidgetConsumerRecordcommonWidgetProducerRecord-- |Constructs a GTK+-based window brick.windowBrick::(OptRecordiOptRecord,RecordSignalKind(AlliOptRecord),RecordSignalKindoRecord)=>IOnativeWindow-- ^an action which creates a native window->(nativeWindow->Gtk.Window)-- ^converts a native window into a Gtk2Hs window->ContextConsumerRecordnativeWindow(AlliOptRecord)-- ^consumers of those inputs which are specific to this brick->ContextProducerRecordnativeWindowoRecord-- ^producers of those outputs which are specific to this brick->BrickWindowGTKiOptRecordoRecordwindowBrick=brickOrBoxbrickcommonWindowConsumerRecordcommonWindowProducerRecord-- |Constructs a GTK+-based widget box.widgetBox::(UICompinnerUIComp,OptRecordiOptRecord,RecordSignalKind(AlliOptRecord),RecordSignalKindoRecord)=>IOnativeWidget-- ^an action which creates a native widget->(nativeWidget->Gtk.Widget)-- ^converts a native widget into a Gtk2Hs widget->(nativeWidget->PlacementinnerItemGTK)-- ^conversion from a native widget into the placement for its inner items->ContextConsumerRecordnativeWidget(AlliOptRecord)-- ^consumers of those inputs which are specific to this box->ContextProducerRecordnativeWidgetoRecord-- ^producers of those outputs which are specific to this box->BoxinnerUICompinnerItemWidgetGTKiOptRecordoRecordwidgetBox=brickOrBoxUIItem.boxcommonWidgetConsumerRecordcommonWidgetProducerRecord-- |Constructs a GTK+-based window box.windowBox::(UICompinnerUIComp,OptRecordiOptRecord,RecordSignalKind(AlliOptRecord),RecordSignalKindoRecord)=>IOnativeWindow-- ^an action which creates a native window->(nativeWindow->Gtk.Window)-- ^converts a native window into a Gtk2Hs window->(nativeWindow->PlacementinnerItemGTK)-- ^conversion from a native window into the placement for its inner items->ContextConsumerRecordnativeWindow(AlliOptRecord)-- ^consumers of those inputs which are specific to this box->ContextProducerRecordnativeWindowoRecord-- ^producers of those outputs which are specific to this box->BoxinnerUICompinnerItemWindowGTKiOptRecordoRecordwindowBox=brickOrBoxUIItem.boxcommonWindowConsumerRecordcommonWindowProducerRecordbrickOrBox::(Gtk.WidgetClassgtkItem,RecordSignalKindiRecord,RecordSignalKindoRecord)=>(ContextConsumerRecordnativeItemiRecord->ContextProducerRecordnativeItemoRecord->(nativeItem->IO())->((gtkItem->IO())->IOnativeItem)->result)->ContextConsumerRecordgtkItemiRecord->ContextProducerRecordgtkItemoRecord->IOnativeItem->(nativeItem->gtkItem)->resultbrickOrBoxgenericBrickOrBoxcontextConsumerscontextProducersnewNativeItemtoGtkItem=genericBrickOrBox(Record.map(brickOrBoxTransformertoGtkItem)contextConsumers)(Record.map(brickOrBoxTransformertoGtkItem)contextProducers)(Gtk.widgetShowAll.toGtkItem){-FIXME:
Using widgetShowAll instead of widgetShow
is just a temporary hack for supporting
tree views inside scrolled windows.
-}newItemwherenewItemplacement=donativeItem<-newNativeItemplacement(toGtkItemnativeItem)returnnativeItembrickOrBoxTransformer::(nativeItem->gtkItem)->ForallSignalKind(TransformerPiece(ContextConnectorStylegtkItemconnector)(ContextConnectorStylenativeItemconnector))brickOrBoxTransformertoGtkItem=SignalForall(TransformerPiece(.toGtkItem))commonWidgetConsumerRecord::ContextConsumerRecordGtk.Widget(All(CommonInputOptRecordWidget))commonWidgetConsumerRecord=X:&IsEnabled:=SSignal.consumer.Gtk.widgetSetSensitivitycommonWidgetProducerRecord::ContextProducerRecordGtk.Widget(CommonOutputRecordWindow)commonWidgetProducerRecord=XcommonWindowConsumerRecord::ContextConsumerRecordGtk.Window(All(CommonInputOptRecordWindow))commonWindowConsumerRecord=XcommonWindowProducerRecord::ContextProducerRecordGtk.Window(CommonOutputRecordWindow)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.GObjectClassgObject)=>Glib.ReadWriteAttrgObjectreadValwriteVal->gObject->ConsumerSSignalwriteValattrConsumergAttrgObject=SSignal.consumer$\val->Glib.setgObject[gAttrGlib.:=val]-- |Constructs a producer of discrete signals that represent sequences of Gtk2Hs events.eventProducer::(Glib.GObjectClassgObject)=>(gObject->IO()->IO(Glib.ConnectIdgObject)){-^
an @on/EventType/@ function of Gtk2Hs, representing a certain kind of
event
-}->gObject-- ^a Gtk2Hs widget which provides the events->ProducerDSignal()eventProduceronEventgObject=DSignal.producer(registeronEventgObject.($())){-|
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.GObjectClassgObject)=>(gObject->IOval)-- ^an action which provides the current value of the produced signal->(gObject->IO()->IO(Glib.ConnectIdgObject)){-^
an @on/EventType/@ function of Gtk2Hs whose corresponding events mark
the update points of the produced signal except the update point at the
beginning of the era
-}->gObject-- ^a Gtk2Hs widget->ProducerSSignalvalreadEventProducerreadValonEventgObject=SSignal.producer(readValgObject)(registeronEventgObject){-|
Constructs a producer of segmented signals that reflect a Gtk2Hs attribute and are updated
on certain Gtk2Hs events.
-}attrEventProducer::(Glib.GObjectClassgObject)=>Glib.ReadWriteAttrgObjectreadValwriteVal-- ^a Gtk2Hs attribute providing the values of the produced signal->(gObject->IO()->IO(Glib.ConnectIdgObject)){-^
an @on/EventType/@ function of Gtk2Hs whose corresponding events mark
the update points of the produced signal except the update point at the
beginning of the era
-}->gObject-- ^a Gtk2Hs widget->ProducerSSignalreadValattrEventProducergAttr=readEventProducer(flipGlib.getgAttr)register::(Glib.GObjectClassgObject)=>(gObject->IO()->IO(Glib.ConnectIdgObject))->gObject->(IO()->Setup)registeronEventgObjecthandler=setup$doconnectID<-onEventgObjecthandlerreturn(Glib.signalDisconnectconnectID)