As a digression to my experiments with GTK4 and Haskell, inspired by a question at the Haskell Community, I looked at list views.

A list view brings together a selection model and a list item factory. A selection model adds support for selection to a list model. A list item factory creates widgets for the list items of a list model. The properties of a list item include an item from the list model, the position of the item in the list model, and the child widget used to display the item.

A list of strings

A simple list model is a value of type StringList. Its items are values of type StringObject. A simple selection model is a value of type SingleSelection.

An example of a list item factory is a value of type SignalListItemFactory. It emits signals, such as setup and bind, to manage list items.

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

module Main
  ( main
  ) where

import           Control.Monad ( void )
import           Control.Monad.Extra ( whenJust )
import           Data.GI.Base ( AttrOp (..), castTo, get, new, on, set )
import           Data.Text ( Text )
import qualified GI.Gtk as Gtk

activate :: Gtk.Application -> IO ()
activate app = do
  stringList <- Gtk.stringListNew (Just exampleList)
  singleSelection <- Gtk.singleSelectionNew (Just stringList)
  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 = do
        mListItem <- castTo Gtk.ListItem o
        whenJust mListItem $ \listItem -> do
          mItem <- get listItem #item
          whenJust mItem $ \item -> do
            mStringObject <- castTo Gtk.StringObject item
            whenJust mStringObject $ \stringObject -> do
              mWidget <- get listItem #child
              whenJust mWidget $ \widget -> do
                mLabel <- castTo Gtk.Label widget
                whenJust mLabel $ \label -> do
                  string <- get stringObject #string
                  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"
    , #child := scrolledWindow
    , #defaultHeight := 200
    ]
  window.show

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

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

{-# LANGUAGE ImplicitParams #-}

{-# LANGUAGE OverloadedLabels #-}

{-# LANGUAGE OverloadedRecordDot #-}

{-# LANGUAGE OverloadedStrings #-}

module Main

( main

) where

import Control.Monad ( void )

import Control.Monad.Extra ( whenJust )

import Data.GI.Base ( AttrOp (..), castTo, get, new, on, set )

import Data.Text ( Text )

import qualified GI.Gtk as Gtk

activate :: Gtk.Application -> IO ()

activate app = do

stringList <- Gtk.stringListNew (Just exampleList)

singleSelection <- Gtk.singleSelectionNew (Just stringList)

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 = do

mListItem <- castTo Gtk.ListItem o

whenJust mListItem $ \listItem -> do

mItem <- get listItem #item

whenJust mItem $ \item -> do

mStringObject <- castTo Gtk.StringObject item

whenJust mStringObject $ \stringObject -> do

mWidget <- get listItem #child

whenJust mWidget $ \widget -> do

mLabel <- castTo Gtk.Label widget

whenJust mLabel $ \label -> do

string <- get stringObject #string

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"

, #child := scrolledWindow

, #defaultHeight := 200

]

window.show

exampleList :: [Text]

exampleList =

[ "apple"

, "banana"

, "cherry"

, "damson"

, "elderberry"

, "fig"

, "grape"

, "kiwi"

, "lemon"

, "mango"

, "nectarine"

, "orange"

, "peach"

, "quince"

, "raspberry"

, "strawberry"

, "tangerine"

, "watermelon"

]

main :: IO ()

main = do

app <- new Gtk.Application

[ #applicationId := "com.pilgrem.testListView"

, On #activate (activate ?self)

]

void $ app.run Nothing

Following a suggestion by Barry Fishman, an alternative to nested whenJust is the use of MaybeT, as follows:

bindListItem :: Gtk.SignalListItemFactoryBindCallback
bindListItem o = void $ runMaybeT $ do
  listItem <- MaybeT $ castTo Gtk.ListItem o
  item <- MaybeT $ get listItem #item
  stringObject <- MaybeT $ castTo Gtk.StringObject item
  widget <- MaybeT $ get listItem #child
  label <- MaybeT $ castTo Gtk.Label widget
  liftIO $ do
    string <- get stringObject #string
    set label [ #label := string ]

bindListItem :: Gtk.SignalListItemFactoryBindCallback

bindListItem o = void $ runMaybeT $ do

listItem <- MaybeT $ castTo Gtk.ListItem o

item <- MaybeT $ get listItem #item

stringObject <- MaybeT $ castTo Gtk.StringObject item

widget <- MaybeT $ get listItem #child

label <- MaybeT $ castTo Gtk.Label widget

liftIO $ do

string <- get stringObject #string

set label [ #label := string ]

The result was as follows:

A list of values of another type

A more complex list model is a value of type GI.Gio.Objects.ListStore, provided by the gi-gio package. Two key functions are:

listStoreNew ::
     (HasCallStack, MonadIO m)
  => GType
     -- ^ The GType of all items.
  -> m ListStore

listStoreInsert ::
     (HasCallStack, MonadIO m, IsListStore a, IsObject b)
  => a
     -- ^ A ListStore.
  -> Word32
     -- ^ The position at which to insert the new item.
  -> b
     -- ^ The new item.
  -> m ()

listStoreNew ::

(HasCallStack, MonadIO m)

=> GType

-- ^ The GType of all items.

-> m ListStore

listStoreInsert ::

(HasCallStack, MonadIO m, IsListStore a, IsObject b)

=> a

-- ^ A ListStore.

-> Word32

-- ^ The position at which to insert the new item.

-> b

-- ^ The new item.

-> m ()

All the items in the list model are of the same type, which must be an instance of type class IsObject and, consequently, an instance of type classes GObject, TypedObject and HasParentTypes. Types that are instances of GObject are specified with newtype and have a data constructor of type ManagedPtr o -> o.

ParentTypes is an open indexed type family, with a kind of a list of concrete types ([Type]):

type family ParentTypes a :: [Type]

1	type family ParentTypes a :: [Type]

Open indexed type families are provided by the TypeFamilies language extension. The DataKinds language extension provides lists at the type level, with the syntax [] (empty list) and [Type] (list with single element).

Class TypedObject promises glibType :: IO GType, which is implemented using registerGType. That, in turn, requires the type to be an instance of DerivedGObject.

{-# 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)

type instance ParentTypes MyTypeObject = '[Object]

instance HasParentTypes 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 = []

{-# 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)

type instance ParentTypes MyTypeObject = '[Object]

instance HasParentTypes 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 = []

The modified program is:

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

module Main
  ( main
  ) where

import           Control.Monad ( void )
import           Control.Monad.Extra ( whenJust )
import           Control.Monad.IO.Class ( MonadIO (..) )
import           Control.Monad.Trans.Maybe ( MaybeT (..) )
import           Data.MyTypeObject
import           Data.GI.Base (  AttrOp (..), castTo, get, 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
  exampleList <- exampleObjects
  Gio.listStoreSplice listStore 0 0 exampleList
  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
        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

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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

{-# LANGUAGE ImplicitParams #-}

{-# LANGUAGE OverloadedLabels #-}

{-# LANGUAGE OverloadedRecordDot #-}

{-# LANGUAGE OverloadedStrings #-}

module Main

( main

) where

import Control.Monad ( void )

import Control.Monad.Extra ( whenJust )

import Control.Monad.IO.Class ( MonadIO (..) )

import Control.Monad.Trans.Maybe ( MaybeT (..) )

import Data.MyTypeObject

import Data.GI.Base ( AttrOp (..), castTo, get, 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

exampleList <- exampleObjects

Gio.listStoreSplice listStore 0 0 exampleList

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

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

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

The result was as follows:

Haskell, GTK4 and list views

A list of strings

A list of values of another type

Haskell, GTK4 and printing