never executed always true always false
    1 {-|
    2 Module: Flaw.Editor.Entity.Basic
    3 Description: Basic instances of 'Entity' typeclass.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE FlexibleInstances, OverloadedStrings, TemplateHaskell, TypeFamilies, ViewPatterns #-}
    8 {-# OPTIONS_GHC -fno-warn-orphans #-}
    9 
   10 module Flaw.Editor.Entity.Basic
   11   ( Folder
   12   ) where
   13 
   14 import Control.Concurrent.STM
   15 import Control.Monad.Reader
   16 import Control.Monad.State.Strict
   17 import qualified Data.ByteArray.Encoding as BA
   18 import qualified Data.ByteString as B
   19 import qualified Data.ByteString.Short as BS
   20 import Data.Default
   21 import Data.Int
   22 import qualified Data.Map.Strict as M
   23 import Data.Serialize.Text()
   24 import qualified Data.Set as S
   25 import qualified Data.Text as T
   26 import qualified Data.Text.Encoding as T
   27 import Data.Word
   28 import Numeric
   29 import Text.Read(readMaybe)
   30 
   31 import Flaw.Editor.EditableEntity
   32 import Flaw.Editor.Entity
   33 import Flaw.Math
   34 import Flaw.UI
   35 import Flaw.UI.Button
   36 import Flaw.UI.CheckBox
   37 import Flaw.UI.EditBox
   38 import Flaw.UI.Layout
   39 import Flaw.UI.ListBox
   40 import Flaw.UI.Metrics
   41 import Flaw.UI.Panel
   42 
   43 instance Entity EntityId where
   44   type EntityChange EntityId = EntityId
   45   getEntityTypeId _ = $(hashTextToEntityTypeId "EntityId")
   46   processEntityChange = processBasicEntityChange
   47   applyEntityChange = applyBasicEntityChange
   48   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
   49   entityToText (EntityId entityIdBytes) = "entityid:" <> T.decodeUtf8 (BA.convertToBase BA.Base64 $ BS.fromShort entityIdBytes)
   50 instance BasicEntity EntityId
   51 instance EditableEntity EntityId where
   52   editableEntityTypeName _ = "EntityId"
   53   editableEntityConstructorName _ = "EntityId"
   54   editableEntityLayout = editBoxEditableLayout
   55     (\(EntityId bytes) -> T.decodeUtf8 $ BA.convertToBase BA.Base64URLUnpadded $ BS.fromShort bytes)
   56     (either (const Nothing) (Just . EntityId . BS.toShort) . BA.convertFromBase BA.Base64URLUnpadded . T.encodeUtf8)
   57 
   58 instance Entity Int32 where
   59   type EntityChange Int32 = Int32
   60   getEntityTypeId _ = $(hashTextToEntityTypeId "Int32")
   61   processEntityChange = processBasicEntityChange
   62   applyEntityChange = applyBasicEntityChange
   63   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
   64 instance BasicEntity Int32
   65 instance EditableEntity Int32 where
   66   editableEntityTypeName _ = "Int32"
   67   editableEntityConstructorName _ = "Int32"
   68   editableEntityLayout = editBoxShowReadEditableLayout
   69 
   70 instance Entity Int64 where
   71   type EntityChange Int64 = Int64
   72   getEntityTypeId _ = $(hashTextToEntityTypeId "Int64")
   73   processEntityChange = processBasicEntityChange
   74   applyEntityChange = applyBasicEntityChange
   75   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
   76 instance BasicEntity Int64
   77 instance EditableEntity Int64 where
   78   editableEntityTypeName _ = "Int64"
   79   editableEntityConstructorName _ = "Int64"
   80   editableEntityLayout = editBoxShowReadEditableLayout
   81 
   82 instance Entity Word32 where
   83   type EntityChange Word32 = Word32
   84   getEntityTypeId _ = $(hashTextToEntityTypeId "Word32")
   85   processEntityChange = processBasicEntityChange
   86   applyEntityChange = applyBasicEntityChange
   87   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
   88 instance BasicEntity Word32
   89 instance EditableEntity Word32 where
   90   editableEntityTypeName _ = "Word32"
   91   editableEntityConstructorName _ = "Word32"
   92   editableEntityLayout = editBoxShowReadEditableLayout
   93 
   94 instance Entity Word64 where
   95   type EntityChange Word64 = Word64
   96   getEntityTypeId _ = $(hashTextToEntityTypeId "Word64")
   97   processEntityChange = processBasicEntityChange
   98   applyEntityChange = applyBasicEntityChange
   99   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
  100 instance BasicEntity Word64
  101 instance EditableEntity Word64 where
  102   editableEntityTypeName _ = "Word64"
  103   editableEntityConstructorName _ = "Word64"
  104   editableEntityLayout = editBoxShowReadEditableLayout
  105 
  106 instance Entity Integer where
  107   type EntityChange Integer = Integer
  108   getEntityTypeId _ = $(hashTextToEntityTypeId "Integer")
  109   processEntityChange = processBasicEntityChange
  110   applyEntityChange = applyBasicEntityChange
  111   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
  112 instance BasicEntity Integer
  113 instance EditableEntity Integer where
  114   editableEntityTypeName _ = "Integer"
  115   editableEntityConstructorName _ = "Integer"
  116   editableEntityLayout = editBoxShowReadEditableLayout
  117 
  118 instance Entity Float where
  119   type EntityChange Float = Float
  120   getEntityTypeId _ = $(hashTextToEntityTypeId "Float")
  121   processEntityChange = processBasicEntityChange
  122   applyEntityChange = applyBasicEntityChange
  123   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
  124   entityToText n = T.pack $ showFFloat Nothing n ""
  125 instance BasicEntity Float
  126 instance EditableEntity Float where
  127   editableEntityTypeName _ = "Float"
  128   editableEntityConstructorName _ = "Float"
  129   editableEntityLayout = editBoxEditableLayout entityToText (readMaybe . T.unpack)
  130 
  131 instance Entity (Vec2 Float) where
  132   type EntityChange (Vec2 Float) = (Vec2 Float)
  133   getEntityTypeId _ = $(hashTextToEntityTypeId "Float2")
  134   processEntityChange = processBasicEntityChange
  135   applyEntityChange = applyBasicEntityChange
  136   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
  137   entityToText = T.unwords . map entityToText . vecToList
  138 instance BasicEntity (Vec2 Float)
  139 instance EditableEntity (Vec2 Float) where
  140   editableEntityTypeName _ = "Float2"
  141   editableEntityConstructorName _ = "Float2"
  142   editableEntityLayout = editBoxVecEditableLayout maybeVecFromList where
  143     maybeVecFromList [x, y] = Just $ Float2 x y
  144     maybeVecFromList _ = Nothing
  145 
  146 instance Entity (Vec3 Float) where
  147   type EntityChange (Vec3 Float) = (Vec3 Float)
  148   getEntityTypeId _ = $(hashTextToEntityTypeId "Float3")
  149   processEntityChange = processBasicEntityChange
  150   applyEntityChange = applyBasicEntityChange
  151   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
  152   entityToText = T.unwords . map entityToText . vecToList
  153 instance BasicEntity (Vec3 Float)
  154 instance EditableEntity (Vec3 Float) where
  155   editableEntityTypeName _ = "Float3"
  156   editableEntityConstructorName _ = "Float3"
  157   editableEntityLayout = editBoxVecEditableLayout maybeVecFromList where
  158     maybeVecFromList [x, y, z] = Just $ Float3 x y z
  159     maybeVecFromList _ = Nothing
  160 
  161 instance Entity (Vec4 Float) where
  162   type EntityChange (Vec4 Float) = (Vec4 Float)
  163   getEntityTypeId _ = $(hashTextToEntityTypeId "Float4")
  164   processEntityChange = processBasicEntityChange
  165   applyEntityChange = applyBasicEntityChange
  166   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
  167   entityToText = T.unwords . map entityToText . vecToList
  168 instance BasicEntity (Vec4 Float)
  169 instance EditableEntity (Vec4 Float) where
  170   editableEntityTypeName _ = "Float4"
  171   editableEntityConstructorName _ = "Float4"
  172   editableEntityLayout = editBoxVecEditableLayout maybeVecFromList where
  173     maybeVecFromList [x, y, z, w] = Just $ Float4 x y z w
  174     maybeVecFromList _ = Nothing
  175 
  176 editBoxVecEditableLayout :: (BasicEntity v, Eq v, Read a) => ([a] -> Maybe v) -> v -> (EntityChange v -> STM ()) -> EditableLayoutM (v -> EntityChange v -> STM ())
  177 editBoxVecEditableLayout maybeVecFromList = editBoxEditableLayout entityToText ((maybeVecFromList =<<) . mapM readMaybe . words . T.unpack)
  178 
  179 instance Entity Bool where
  180   type EntityChange Bool = Bool
  181   getEntityTypeId _ = $(hashTextToEntityTypeId "Bool")
  182   processEntityChange = processBasicEntityChange
  183   applyEntityChange = applyBasicEntityChange
  184   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
  185 instance BasicEntity Bool
  186 instance Default Bool where
  187   def = False
  188 instance EditableEntity Bool where
  189   editableEntityTypeName _ = "Bool"
  190   editableEntityConstructorName _ = "Bool"
  191   editableEntityLayout initialEntity setter = ReaderT $ \EditableLayoutState {} -> do
  192     currentValueVar <- lift $ newTVar initialEntity
  193     checkBox <- lift $ newLabeledCheckBox "enabled"
  194     lift $ setChecked checkBox initialEntity
  195     FlowLayoutState
  196       { flsMetrics = metrics
  197       } <- get
  198     elementWithSizeInFlowLayout checkBox (preferredSize metrics checkBox)
  199     lift $ setChangeHandler checkBox $ do
  200       value <- getChecked checkBox
  201       currentValue <- readTVar currentValueVar
  202       when (value /= currentValue) $ do
  203         writeTVar currentValueVar value
  204         setter value
  205     return $ \newValue _change -> do
  206       writeTVar currentValueVar newValue
  207       setChecked checkBox newValue
  208 
  209 instance Entity B.ByteString where
  210   type EntityChange B.ByteString = B.ByteString
  211   getEntityTypeId _ = $(hashTextToEntityTypeId "ByteString")
  212   processEntityChange = processBasicEntityChange
  213   applyEntityChange = applyBasicEntityChange
  214 instance BasicEntity B.ByteString
  215 instance Default B.ByteString where
  216   def = B.empty
  217 
  218 instance Entity T.Text where
  219   type EntityChange T.Text = T.Text
  220   getEntityTypeId _ = $(hashTextToEntityTypeId "Text")
  221   processEntityChange = processBasicEntityChange
  222   applyEntityChange = applyBasicEntityChange
  223   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
  224   entityToText = id
  225 instance BasicEntity T.Text
  226 instance Default T.Text where
  227   def = T.empty
  228 instance EditableEntity T.Text where
  229   editableEntityTypeName _ = "Text"
  230   editableEntityConstructorName _ = "Text"
  231   editableEntityLayout = editBoxEditableLayout id Just
  232 
  233 -- | Layout with edit box.
  234 editBoxEditableLayout :: (BasicEntity a, Eq a) => (a -> T.Text) -> (T.Text -> Maybe a) -> a -> (EntityChange a -> STM ()) -> EditableLayoutM (a -> EntityChange a -> STM ())
  235 editBoxEditableLayout toText fromText initialEntity setter = ReaderT $ \EditableLayoutState {} -> do
  236   currentValueVar <- lift $ newTVar initialEntity
  237   panel <- lift $ newPanel False
  238   editBox <- lift newEditBox
  239   lift $ setText editBox $ toText initialEntity
  240   _editBoxChild <- lift $ addFreeChild panel editBox
  241   lift $ setLayoutHandler panel $ layoutElement editBox
  242   FlowLayoutState
  243     { flsMetrics = metrics
  244     } <- get
  245   elementWithSizeInFlowLayout panel (preferredSize metrics editBox)
  246   lift $ setCommitHandler panel $ \commitReason -> do
  247     setText editBox =<<
  248       if commitReason == CommitAccept || commitReason == CommitLostFocus then do
  249         maybeValue <- fromText <$> getText editBox
  250         case maybeValue of
  251           Just value -> do
  252             currentValue <- readTVar currentValueVar
  253             when (value /= currentValue) $ do
  254               writeTVar currentValueVar value
  255               setter value
  256             return $ toText value
  257           Nothing -> toText <$> readTVar currentValueVar
  258       else toText <$> readTVar currentValueVar
  259     return True
  260   return $ \newValue _change -> do
  261     -- check that it's not equal to current value
  262     currentValue <- readTVar currentValueVar
  263     when (newValue /= currentValue) $ do
  264       -- in any case remember new current value
  265       writeTVar currentValueVar newValue
  266       -- change text in edit box only if it's not changed
  267       maybeValue <- fromText <$> getText editBox
  268       case maybeValue of
  269         Just value -> when (value == currentValue) $ setText editBox $ toText newValue
  270         Nothing -> return ()
  271 
  272 -- | Layout with edit box using 'Show' and 'Read' for conversion.
  273 editBoxShowReadEditableLayout :: (BasicEntity a, Eq a, Show a, Read a) => a -> (EntityChange a -> STM ()) -> EditableLayoutM (a -> EntityChange a -> STM ())
  274 editBoxShowReadEditableLayout = editBoxEditableLayout (T.pack . show) (readMaybe . T.unpack)
  275 
  276 -- EntityPtr
  277 
  278 entityPtrFirstEntityTypeId :: EntityTypeId
  279 entityPtrFirstEntityTypeId = $(hashTextToEntityTypeId "EntityPtr")
  280 
  281 instance Entity a => Entity (EntityPtr a) where
  282   type EntityChange (EntityPtr a) = EntityPtr a
  283   processEntityChange = processBasicEntityChange
  284   applyEntityChange = applyBasicEntityChange
  285   getEntityTypeId = f undefined where
  286     f :: Entity a => a -> EntityPtr a -> EntityTypeId
  287     f u _ = entityPtrFirstEntityTypeId <> getEntityTypeId u
  288 instance Entity a => BasicEntity (EntityPtr a) where
  289   serializeBasicEntity (EntityPtr underlyingEntityId) = serializeBasicEntity underlyingEntityId
  290   deserializeBasicEntity = EntityPtr . deserializeBasicEntity
  291 
  292 instance EntityRegistration EntityPtr where
  293   performEntityRegistration entityManager _ = registerBasicOrdEntityType entityManager entityPtrFirstEntityTypeId $ do
  294     SomeEntity underlyingBaseEntity <- getRootBaseEntity
  295     let
  296       setType :: a -> EntityPtr a
  297       setType _ = EntityPtr nullEntityId
  298     return $ SomeBasicOrdEntity $ setType underlyingBaseEntity
  299 
  300 -- InterfacedEntityPtr
  301 
  302 interfacedEntityPtrFirstEntityTypeId :: EntityTypeId
  303 interfacedEntityPtrFirstEntityTypeId = $(hashTextToEntityTypeId "InterfacedEntityPtr")
  304 
  305 instance EntityInterface i => Entity (InterfacedEntityPtr i) where
  306   type EntityChange (InterfacedEntityPtr i) = InterfacedEntityPtr i
  307   processEntityChange = processBasicEntityChange
  308   applyEntityChange = applyBasicEntityChange
  309   getEntityTypeId = f Proxy where
  310     f :: EntityInterface i => Proxy i -> InterfacedEntityPtr i -> EntityTypeId
  311     f proxy _ = let
  312       EntityInterfaceId entityInterfaceIdBytes = getEntityInterfaceId proxy
  313       in interfacedEntityPtrFirstEntityTypeId <> EntityTypeId entityInterfaceIdBytes
  314 instance EntityInterface i => BasicEntity (InterfacedEntityPtr i) where
  315   serializeBasicEntity (InterfacedEntityPtr underlyingEntityId) = serializeBasicEntity underlyingEntityId
  316   deserializeBasicEntity = InterfacedEntityPtr . deserializeBasicEntity
  317 
  318 instance EntityRegistration InterfacedEntityPtr where
  319   performEntityRegistration entityManager _ = registerBasicOrdEntityType entityManager interfacedEntityPtrFirstEntityTypeId $ do
  320     SomeEntityInterface proxy <- deserializeEntityInterface
  321     let
  322       setType :: Proxy i -> InterfacedEntityPtr i
  323       setType Proxy = InterfacedEntityPtr nullEntityId
  324     return $ SomeBasicOrdEntity $ setType proxy
  325 
  326 -- Set
  327 
  328 setFirstEntityTypeId :: EntityTypeId
  329 setFirstEntityTypeId = $(hashTextToEntityTypeId "Set")
  330 
  331 instance (Ord a, BasicEntity a) => Entity (S.Set a) where
  332   type EntityChange (S.Set a) = (a, Bool)
  333   getEntityTypeId = f undefined where
  334     f :: (Entity a) => a -> S.Set a -> EntityTypeId
  335     f u _ = setFirstEntityTypeId <> getEntityTypeId u
  336   processEntityChange oldEntity keyBytes valueBytes = result where
  337     result = if B.null keyBytes || B.head keyBytes /= 0 then Nothing else Just (newEntity, change)
  338     newEntity = operation oldEntity
  339     (operation, change) =
  340       if B.null valueBytes then (S.delete key, (key, False))
  341       else (S.insert key, (key, True))
  342     key = deserializeBasicEntity $ B.drop 1 keyBytes
  343   applyEntityChange var (value, f) = writeEntityVarRecord var (B.singleton 0 <> serializeBasicEntity value) (if f then B.singleton 1 else B.empty)
  344   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
  345   entityToText s = editableEntityTypeName s <> T.pack (" {" ++ shows (S.size s) "}")
  346 
  347 instance EntityRegistration S.Set where
  348   performEntityRegistration entityManager _ = registerEntityType entityManager setFirstEntityTypeId $ do
  349     SomeBasicOrdEntity underlyingBaseEntity <- getRootBaseBasicOrdEntity
  350     let
  351       setType :: a -> S.Set a
  352       setType _ = S.empty
  353     return $ SomeEntity $ setType underlyingBaseEntity
  354 
  355 instance (Ord a, BasicEntity a) => EditableEntity (S.Set a) where
  356   editableEntityTypeName = f undefined where
  357     f :: Entity a => a -> S.Set a -> T.Text
  358     f u@(interfaceEntity (Proxy :: Proxy EditableEntity) -> EntityInterfaced) _ = "Set<" <> editableEntityTypeName u <> ">"
  359     f _ _ = "Set"
  360   editableEntityConstructorName _ = "Set"
  361   editableEntityLayout initialEntity setter = ReaderT $ \EditableLayoutState {} -> do
  362     currentValueVar <- lift $ newTVar initialEntity
  363     itemHandlesVar <- lift $ newTVar M.empty
  364     FlowLayoutState
  365       { flsMetrics = metrics@Metrics
  366         { metricsMainWidth = metricMainWidth
  367         }
  368       } <- get
  369     let
  370       keyEntityTypeName = let
  371         f :: Entity a => S.Set a -> a -> T.Text
  372         f _ u = case interfaceEntity (Proxy :: Proxy EditableEntity) u of
  373           EntityInterfaced -> editableEntityTypeName u
  374           EntityNotInterfaced -> "value"
  375         in f initialEntity undefined
  376     listBoxColumn <- lift $ newListBoxTextColumnDesc keyEntityTypeName metricMainWidth id entityToText
  377     listBox <- lift $ newListBox metrics [listBoxColumn]
  378 
  379     let
  380       onAdd = return ()
  381       onRemove = do
  382         selectedItems <- getListBoxSelectedValues listBox
  383         forM_ selectedItems $ \selectedItem -> setter (selectedItem, False)
  384     addRemoveButtonsLayout listBox onAdd onRemove
  385 
  386     let
  387       insertItem item = do
  388         itemHandles <- readTVar itemHandlesVar
  389         unless (M.member item itemHandles) $ do
  390           itemHandle <- addListBoxItem listBox item
  391           writeTVar itemHandlesVar $! M.insert item itemHandle itemHandles
  392 
  393       removeItem item = do
  394         itemHandles <- readTVar itemHandlesVar
  395         case M.lookup item itemHandles of
  396           Just itemHandle -> do
  397             removeListBoxItem listBox itemHandle
  398             writeTVar itemHandlesVar $! M.delete item itemHandles
  399           Nothing -> return ()
  400 
  401     lift $ mapM_ insertItem $ S.toList initialEntity
  402 
  403     return $ \newValue (changedKey, changedFlag) -> do
  404       writeTVar currentValueVar newValue
  405       (if changedFlag then insertItem else removeItem) changedKey
  406 
  407 -- Map
  408 
  409 mapFirstEntityTypeId :: EntityTypeId
  410 mapFirstEntityTypeId = $(hashTextToEntityTypeId "Map")
  411 
  412 instance (Ord k, BasicEntity k, BasicEntity v) => Entity (M.Map k v) where
  413   type EntityChange (M.Map k v) = (k, Maybe v)
  414   getEntityTypeId = f undefined undefined where
  415     f :: (Entity k, Entity v) => k -> v -> M.Map k v -> EntityTypeId
  416     f uk uv _ = mapFirstEntityTypeId <> getEntityTypeId uk <> getEntityTypeId uv
  417   processEntityChange oldEntity keyBytes valueBytes = result where
  418     result = if B.null keyBytes || B.head keyBytes /= 0 then Nothing else Just (newEntity, change)
  419     newEntity = operation oldEntity
  420     (operation, change) =
  421       if B.null valueBytes then (M.delete key, (key, Nothing))
  422       else (M.insert key value, (key, Just value))
  423     key = deserializeBasicEntity $ B.drop 1 keyBytes
  424     value = deserializeBasicEntity $ B.drop 1 valueBytes
  425   applyEntityChange var (key, maybeValue) = writeEntityVarRecord var (B.singleton 0 <> serializeBasicEntity key) $ case maybeValue of
  426     Just value -> B.singleton 0 <> serializeBasicEntity value
  427     Nothing -> B.empty
  428   interfaceEntity = $(interfaceEntityExp [''EditableEntity])
  429   entityToText m = T.pack ("map{" ++ shows (M.size m) "}")
  430 
  431 instance EntityRegistration M.Map where
  432   performEntityRegistration entityManager _ = registerEntityType entityManager mapFirstEntityTypeId $ do
  433     SomeBasicOrdEntity underlyingKeyBaseEntity <- getRootBaseBasicOrdEntity
  434     SomeBasicEntity underlyingValueBaseEntity <- getRootBaseBasicEntity
  435     let
  436       setType :: k -> v -> M.Map k v
  437       setType _ _ = M.empty
  438     return $ SomeEntity $ setType underlyingKeyBaseEntity underlyingValueBaseEntity
  439 
  440 instance (Ord k, BasicEntity k, BasicEntity v) => EditableEntity (M.Map k v) where
  441   editableEntityTypeName = f undefined undefined where
  442     f :: (Entity k, Entity v) => k -> v -> M.Map k v -> T.Text
  443     f
  444       uk@(interfaceEntity (Proxy :: Proxy EditableEntity) -> EntityInterfaced)
  445       uv@(interfaceEntity (Proxy :: Proxy EditableEntity) -> EntityInterfaced)
  446       _ = "Map<" <> editableEntityTypeName uk <> "," <> editableEntityTypeName uv <> ">"
  447     f _ _ _ = "Map"
  448   editableEntityConstructorName _ = "Map"
  449   editableEntityLayout initialEntity setter = ReaderT $ \EditableLayoutState {} -> do
  450     currentValueVar <- lift $ newTVar initialEntity
  451     itemHandlesVar <- lift $ newTVar M.empty
  452     FlowLayoutState
  453       { flsMetrics = metrics@Metrics
  454         { metricsMainWidth = metricMainWidth
  455         }
  456       } <- get
  457 
  458     let
  459       (keyEntityTypeName, valueEntityTypeName) = let
  460         f :: (Entity k, Entity v) => M.Map k v -> k -> v -> (T.Text, T.Text)
  461         f _ uk uv =
  462           ( case interfaceEntity (Proxy :: Proxy EditableEntity) uk of
  463             EntityInterfaced -> editableEntityTypeName uk
  464             EntityNotInterfaced -> "key"
  465           , case interfaceEntity (Proxy :: Proxy EditableEntity) uv of
  466             EntityInterfaced -> editableEntityTypeName uv
  467             EntityNotInterfaced -> "value"
  468           )
  469         in f initialEntity undefined undefined
  470 
  471     listBoxKeyColumn <- lift $ newListBoxTextColumnDesc keyEntityTypeName (metricMainWidth `quot` 2) fst (entityToText . fst)
  472     listBoxValueColumn <- lift $ let f = entityToText . snd in newListBoxTextColumnDesc valueEntityTypeName (metricMainWidth `quot` 2) f f
  473     listBox <- lift $ newListBox metrics [listBoxKeyColumn, listBoxValueColumn]
  474 
  475     let
  476       onAdd = return ()
  477 
  478       onRemove = do
  479         selectedItems <- getListBoxSelectedValues listBox
  480         forM_ selectedItems $ \(selectedKey, _selectedValue) -> setter (selectedKey, Nothing)
  481 
  482     addRemoveButtonsLayout listBox onAdd onRemove
  483 
  484     let
  485       insertItem item@(itemKey, _itemValue) = do
  486         itemHandles <- readTVar itemHandlesVar
  487         unless (M.member itemKey itemHandles) $ do
  488           itemHandle <- addListBoxItem listBox item
  489           writeTVar itemHandlesVar $! M.insert itemKey itemHandle itemHandles
  490 
  491       removeItem itemKey = do
  492         itemHandles <- readTVar itemHandlesVar
  493         case M.lookup itemKey itemHandles of
  494           Just itemHandle -> do
  495             removeListBoxItem listBox itemHandle
  496             writeTVar itemHandlesVar $! M.delete itemKey itemHandles
  497           Nothing -> return ()
  498 
  499     lift $ mapM_ insertItem $ M.toList initialEntity
  500 
  501     return $ \newValue (changedKey, changedMaybeInsertedValue) -> do
  502       writeTVar currentValueVar newValue
  503       case changedMaybeInsertedValue of
  504         Just insertedValue -> insertItem (changedKey, insertedValue)
  505         Nothing -> removeItem changedKey
  506 
  507 -- | Helper function: layout add and remove buttons
  508 addRemoveButtonsLayout :: ListBox a -> STM () -> STM () -> FlowLayoutM ()
  509 addRemoveButtonsLayout listBox onAdd onRemove = StateT $ \s@FlowLayoutState
  510   { flsMetrics = Metrics
  511     { metricsGap = metricGap
  512     , metricsMainWidth = metricMainWidth
  513     , metricsButtonSize = Vec2 _ metricButtonHeight
  514     , metricsListBoxItemHeight = metricListBoxItemHeight
  515     }
  516   , flsParentElement = parentElement
  517   , flsLayoutHandler = lh
  518   , flsPreSize = Vec2 psx psy
  519   } -> do
  520   listBoxChild <- addFreeChild parentElement listBox
  521 
  522   addButton <- newLabeledButton "+"
  523   setActionHandler addButton onAdd
  524   addButtonChild <- addFreeChild parentElement addButton
  525   layoutElement addButton $ Vec2 metricButtonHeight metricButtonHeight
  526 
  527   removeButton <- newLabeledButton "-"
  528   setActionHandler removeButton onRemove
  529   removeButtonChild <- addFreeChild parentElement removeButton
  530   layoutElement removeButton $ Vec2 metricButtonHeight metricButtonHeight
  531 
  532   return ((), s
  533     { flsLayoutHandler = lh >=> \(Vec4 px py qx qy) -> do
  534       placeFreeChild parentElement listBoxChild $ Vec2 px py
  535       layoutElement listBox $ Vec2 (qx - px) (qy - py - metricGap - metricButtonHeight)
  536       placeFreeChild parentElement addButtonChild $ Vec2 (qx - metricButtonHeight * 2 - metricGap) (qy - metricButtonHeight)
  537       placeFreeChild parentElement removeButtonChild $ Vec2 (qx - metricButtonHeight) (qy - metricButtonHeight)
  538       return $ Vec4 px qy qx qy
  539     , flsPreSize = Vec2 (max psx metricMainWidth) (psy + metricListBoxItemHeight * 7 + metricGap)
  540     })
  541 
  542 
  543 -- some synonyms
  544 
  545 type Folder = M.Map T.Text EntityId