Continuing my own experiments, I varied my ‘complex’ example to allow sorting of the list store (MyTypePrivate was made an instance of Ord):
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main
( main
) where
import Control.Monad ( void )
import Control.Monad.IO.Class ( MonadIO (..))
import Control.Monad.Extra ( whenJust )
import Control.Monad.Trans.Maybe ( MaybeT (..) )
import Data.MyTypeObject
import Data.GI.Base
( AttrOp (..), castTo, get, new, on, set, withNewObject )
import Data.GI.Base.GObject
( DerivedGObject (..), gobjectGetPrivateData
, gobjectSetPrivateData, registerGType
)
import Data.Text ( Text, pack )
import Foreign.Ptr ( Ptr, castPtr )
import GI.GObject ( Object (..), toObject )
import qualified GI.Gio as Gio
import qualified GI.GLib as GLib
import qualified GI.Gtk as Gtk
activate :: Gtk.Application -> IO ()
activate app = do
gType <- registerGType MyTypeObject
listStore <- Gio.listStoreNew gType
exampleList <- exampleObjects
Gio.listStoreSplice listStore 0 0 exampleList
#sort listStore (compareDataFunc MyTypeObject)
singleSelection <- Gtk.singleSelectionNew (Just listStore)
signalListItemFactory <- Gtk.signalListItemFactoryNew
scrolledWindow <- Gtk.scrolledWindowNew
let setupListItem :: Gtk.SignalListItemFactorySetupCallback
setupListItem o = do
mListItem <- castTo Gtk.ListItem o
whenJust mListItem $ \listItem -> do
label <- new Gtk.Label []
set listItem [ #child := label ]
let bindListItem :: Gtk.SignalListItemFactoryBindCallback
bindListItem o = void $ runMaybeT $ do
listItem <- MaybeT $ castTo Gtk.ListItem o
item <- MaybeT $ get listItem #item
myTypeObject <- MaybeT $ castTo MyTypeObject item
widget <- MaybeT $ get listItem #child
label <- MaybeT $ castTo Gtk.Label widget
liftIO $ do
myTypePrivate <- gobjectGetPrivateData myTypeObject
let string = case myTypePrivate of
MyTypePrivate (Just f) (Just c) ->
f <> " (" <> pack (show c) <> ")"
MyTypePrivate (Just f) Nothing -> f
MyTypePrivate _ _ -> ""
set label [ #label := string ]
void $ on signalListItemFactory #setup setupListItem
void $ on signalListItemFactory #bind bindListItem
listView <-
Gtk.listViewNew (Just singleSelection) (Just signalListItemFactory)
set scrolledWindow [ #child := listView ]
window <- new Gtk.ApplicationWindow
[ #application := app
, #title := "ListView test (complex)"
, #child := scrolledWindow
, #defaultHeight := 200
]
window.show
exampleFruitJumbled :: [Text]
exampleFruitJumbled =
[ "apple"
, "tangerine"
, "banana"
, "strawberry"
, "cherry"
, "raspberry"
, "damson"
, "quince"
, "elderberry"
, "fig"
, "peach"
, "grape"
, "orange"
, "kiwi"
, "nectarine"
, "lemon"
, "watermelon"
, "mango"
]
exampleCount :: [Int]
exampleCount = [1 .. 18]
exampleObjects :: IO [Object]
exampleObjects = mapM (toObject =<<) exampleMyType
where
exampleMyType = zipWith go exampleFruitJumbled exampleCount
go f c = do
myTypeObject <- new MyTypeObject []
gobjectSetPrivateData myTypeObject $ MyTypePrivate
{ fruit = Just f
, count = Just c
}
pure myTypeObject
compareDataFunc ::
forall o. (DerivedGObject o, Ord (GObjectPrivateData o))
=> (Gtk.ManagedPtr o -> o)
-- ^ The data constructor for the type of the items to be sorted.
-> GLib.CompareDataFunc
compareDataFunc _ ptrA ptrB =
withNewObject ptrA' $ \myTypeObjectA ->
withNewObject ptrB' $ \myTypeObjectB -> do
myTypePrivateA <- gobjectGetPrivateData myTypeObjectA
myTypePrivateB <- gobjectGetPrivateData myTypeObjectB
pure $ case compare myTypePrivateA myTypePrivateB of
LT -> -1
EQ -> 0
GT -> 1
where
ptrA' = castPtr ptrA :: Ptr o
ptrB' = castPtr ptrB :: Ptr o
main :: IO ()
main = do
app <- new Gtk.Application
[ #applicationId := "com.pilgrem.testListView.complex"
, On #activate (activate ?self)
]
void $ app.run Nothing
with package.yaml (extract):
dependencies:
- base >= 4.7 && < 5
- extra
- gi-gio
- gi-glib
- gi-gobject
- gi-gtk >= 4.0
- haskell-gi-base
- text
- transformers
