An experimental list box widget for Threepenny 0.3 (https://github.com/HeinrichApfelmus/threepenny-gui).

ListBox.hs

{-# LANGUAGE RecordWildCards #-}
module ListBox
    ( ListBox
    -- Construction
    , new
    -- Model definition and setup
    , plugModel
    -- Default renderer
    , toElement
    -- Appearance modifiers
    -- User events
    , userValueChange
    -- Widget state manipulation
    -- Utility functions
    , mkListBoxData
    ) where

import Control.Monad (void)
import Data.Maybe (fromMaybe)
import Data.Tuple (swap)
import qualified Data.Map as M
import qualified Data.Traversable as Tr

import qualified Graphics.UI.Threepenny as UI
import Graphics.UI.Threepenny.Core

data ListBox a = ListBox
    { _selListBox :: Element
    , _userSelectionChange :: Event (Maybe Int)
    }

data ListBoxData a = ListBoxData
    { forwardMap :: M.Map Int a
    , reverseMap :: M.Map a Int
    , captions   :: M.Map Int String
    }

new :: IO (ListBox a)
new = do
    _selListBox <- UI.select # set UI.size "10" #. "listbox-select"

    let _userSelectionChange = UI.selectionChange _selListBox
    return ListBox {..}

mkListBoxData :: (Ord a)
              => ([b] -> [b]) -> (b -> String) -> (b -> a)
              -> [b] -> (ListBoxData a)
mkListBoxData fPrepare fCaption fValue xs = ListBoxData
    { forwardMap = M.fromList kvps
    , reverseMap = M.fromList . map swap $ kvps
    , captions   = M.fromList kcps
    }
    where
    xs' = fPrepare xs
    prePairs = zip [0..] xs'
    kvps = map (fmap fValue) prePairs
    kcps = map (fmap fCaption) prePairs

userValueChange :: Behavior (ListBoxData a)
                -> ListBox a -> Event (Maybe a)
userValueChange bvs lb =
    (\vs mx -> mx >>= flip M.lookup vs) . forwardMap <$> bvs
        <@> (_userSelectionChange lb)

plugModel :: (Ord a)
          => ListBox a -> Behavior (ListBoxData a) -> Behavior (Maybe a)
          -> IO (Behavior (Maybe a))
plugModel lb bData bValue = do
    let bForward = forwardMap <$> bData
        bReverse = reverseMap <$> bData
        bIndex =
            pure (>>=) <*> bValue <*> (flip M.lookup <$> bReverse)
        bFinalValue =
            pure (>>=) <*> bIndex <*> (flip M.lookup <$> bForward)
    void $ element (_selListBox lb)
        # sink availableOptions bData
        # sink UI.selection bIndex
    return bFinalValue

availableOptions :: WriteAttr Element (ListBoxData a)
availableOptions = mkWriteAttr $ \lbd sel -> do
    options <- Tr.mapM (\c -> UI.option # set text c) $ captions lbd
    void $ element sel
        # set children [] #+ map element (M.elems options)

toElement :: ListBox a -> IO Element
toElement lb =
    UI.div #. "listbox-widget" #+
        [ element (_selListBox lb) ]