Haskell-gi: How to implement a GLib.CompareDataFunc

Learn
10

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
1 Like