Haskell-gi: How do I create a Gtk.ListView?

Learn
7

My second experiment was more complex, in terms of the list model. I used a GI.Gio.Objects.ListStore with my own MyTypeObject type for the items.

For MyTypeObject, I followed the example at haskell-gi/examples/advanced/CustomContainer.hs at master · haskell-gi/haskell-gi · GitHub to create:

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies      #-}

module Data.MyTypeObject
  ( MyTypeObject (..)
  , MyTypePrivate (..)
  ) where

import           Data.GI.Base
                   ( GObject, ManagedPtr, TypedObject (..), glibType )
import           Data.GI.Base.GObject ( DerivedGObject (..), registerGType )
import           Data.GI.Base.Overloading ( HasParentTypes, ParentTypes )
import           GI.GObject ( Object )
import           Data.Text ( Text )

newtype MyTypeObject = MyTypeObject (ManagedPtr MyTypeObject)

instance TypedObject MyTypeObject where

  glibType = registerGType MyTypeObject

instance GObject MyTypeObject

data MyTypePrivate = MyTypePrivate
  { fruit :: Maybe Text
  , count :: Maybe Int
  }

instance DerivedGObject MyTypeObject where

  type GObjectParentType MyTypeObject = Object

  type GObjectPrivateData MyTypeObject = MyTypePrivate

  objectTypeName = "MyTypeObject"

  objectClassInit _ = pure ()

  objectInstanceInit _ _ = pure $ MyTypePrivate
    { fruit = Nothing
    , count = Nothing
    }

  objectInterfaces = []

instance HasParentTypes MyTypeObject

type instance ParentTypes MyTypeObject = '[Object]

I modified my first experiement to be as follows (I think your use of MaybeT is more expressive, but I have kept with whenJust for now):

{-# LANGUAGE ImplicitParams      #-}
{-# LANGUAGE OverloadedLabels    #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

module Main
  ( main
  ) where

import           Control.Monad ( void )
import           Control.Monad.Extra ( whenJust )
import           Data.MyTypeObject
import           Data.GI.Base (  AttrOp (..), castTo, new, on, set )
import           Data.GI.Base.GObject
                   ( gobjectGetPrivateData, gobjectSetPrivateData
                   , registerGType
                   )
import           Data.Text ( Text, pack )
import           GI.GObject ( Object, toObject )
import qualified GI.Gio as Gio
import qualified GI.Gtk as Gtk

activate :: Gtk.Application -> IO ()
activate app = do
  gType <- registerGType MyTypeObject
  listStore <- Gio.listStoreNew gType
  myTypeList <- exampleObjects
  Gio.listStoreSplice listStore 0 0 myTypeList
  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 []
          #setChild listItem (Just label)

  let bindListItem :: Gtk.SignalListItemFactoryBindCallback
      bindListItem o1 = do
        mListItem <- castTo Gtk.ListItem o1
        whenJust mListItem $ \listItem -> do
          mO2 <- Gtk.listItemGetItem listItem
          whenJust mO2 $ \o2 -> do
            mMyTypeObject <- castTo MyTypeObject o2
            whenJust mMyTypeObject $ \myTypeObject -> do
              mWidget <- #getChild listItem
              whenJust mWidget $ \widget -> do
                mLabel <- castTo Gtk.Label widget
                whenJust mLabel $ \label -> 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

exampleFruit :: [Text]
exampleFruit =
  [ "apple"
  , "banana"
  , "cherry"
  , "damson"
  , "elderberry"
  , "fig"
  , "grape"
  , "kiwi"
  , "lemon"
  , "mango"
  , "nectarine"
  , "orange"
  , "peach"
  , "quince"
  , "raspberry"
  , "strawberry"
  , "tangerine"
  , "watermelon"
  ]

exampleCount :: [Int]
exampleCount = [1 .. 18]

exampleObjects :: IO [Object]
exampleObjects = mapM (toObject =<<) exampleMyType
 where
  exampleMyType = zipWith go exampleFruit exampleCount
  go f c = do
    myTypeObject <- new MyTypeObject []
    gobjectSetPrivateData myTypeObject $ MyTypePrivate
      { fruit = Just f
      , count = Just c
      }
    pure myTypeObject

main :: IO ()
main = do
  app <- new Gtk.Application
    [ #applicationId := "com.pilgrem.testListView.complex"
    , On #activate (activate ?self)
    ]
  void $ app.run Nothing

and result:

image
image475×229 4.6 KB