Makes a UI that allows you to add and remove elements from a tree. See https://www.youtube.com/watch?v=RQiMItSHYjw for it running

treebutt.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Frontend where

import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Reflex.Dom.Core
import Data.Map (Map)
import Data.Foldable (foldl, toList, traverse_)
import qualified Data.Map as M
import Control.Lens
import Control.Monad (join, (>=>))
import Data.Semigroup ((<>))
import Data.Monoid (First(First, getFirst))
import Data.Functor (void)
import Control.Lens.TH (makePrisms)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NEL
import qualified Clay as C

import Common.Api
import Static

type UUID = Integer -- LOL
type UiTreePath = NonEmpty UUID
data UiTree v = Node v (Map UUID (UiTree v)) | Leaf v deriving Show
makePrisms ''UiTree

uiTreeCata :: (v -> Map UUID (UiTree v) -> a) -> (v -> a) -> UiTree v -> a
uiTreeCata node leaf t = case t of
  Node v m -> node v m
  Leaf v   -> leaf v

data UiTreeEvent = UiTreeAdd [UUID] | UiTreeDelete UiTreePath
makePrisms ''UiTreeEvent

frontend :: (StaticWidget x (), Widget x ())
frontend = (head', body)
  where
    head' = do
      el "title" $ text "Tree demo"
      el "style" . text . TL.toStrict $ C.render css
    css = do
      C.ul C.? do
        C.listStyleType C.none
        C.margin  (C.em 0) (C.em 0) (C.em 0) (C.em 0)
        C.padding  (C.em 0) (C.em 0) (C.em 0) (C.em 0)
        C.li C.? do
          C.margin  (C.em 0) (C.em 0) (C.em 0) (C.em 0)
          C.padding  (C.em 0) (C.em 0) (C.em 0) (C.em 0.4)
          C.lineHeight (C.em 1)
          C.borderLeft C.solid (C.px 1) C.black
        C.li C.# ":before" C.? do
          C.position C.relative
          C.top (C.em (-0.3))
          C.height (C.em 1)
          C.width (C.em 1)
          C.borderBottom C.solid (C.px 1) C.black
          C.left (C.em (-0.4))
          C.content (C.stringContent "")
          C.display C.inlineBlock
        C.li C.# ":last-child:before" C.? do
          C.borderLeft C.solid (C.px 1) C.black
        C.li C.# ":last-child" C.? do
          C.borderStyle C.none
        C.ul C.? do
          C.marginLeft (C.em 1)
      C.button C.? do
        C.borderStyle C.none
        C.color C.white
        C.width (C.em 1.2)
        C.marginLeft (C.em 0.2)
        C.lineHeight (C.em 0.8)
        C.padding (C.em 0.2) (C.em 0.2) (C.em 0.2) (C.em 0.2)
        C.textDecoration C.none
      C.button C.# ".delete" C.? do
        C.background C.crimson
      C.button C.# ".add" C.? do
        C.background C.seagreen
    body = mdo
      let addsE = fmapMaybe (^? _UiTreeAdd) evE
      let delsE = ffilter (not . isn't _UiTreeDelete) evE
      cntB <- current <$> count addsE
      let addPE = attachWith (\u us -> UiTreeAdd (u:us)) cntB addsE
      ps <- foldDyn doEvent M.empty $ leftmost [addPE, delsE]
      evE <- el "ul" $ do
        evMapE <- listViewWithKey ps priorityElt
        evTopE <- el "li" $ addB []
        let evE = (head . toList) <$> evMapE
        pure $ leftmost [evTopE, evE]
      pure ()

doEvent :: UiTreeEvent -> Map UUID (UiTree T.Text) -> Map UUID (UiTree T.Text)
doEvent (UiTreeAdd us) m = insertNew "butt" (reverse us) m
doEvent (UiTreeDelete p) m = deleteNode (NEL.reverse p) m

insertNew :: Show v => v -> [UUID] -> Map UUID (UiTree v) -> Map UUID (UiTree v)
insertNew v uus = insertSpine uus
  where
    insertSpine [u]    = M.insert u (Leaf v)
    insertSpine (u:us) = M.adjust (uiTreeCata (descend us) (promote us)) u
    promote [u] nv = Node nv $ M.singleton u (Leaf v)
    promote _ _ = error "Panic! The impossible happened!"
    descend us v = Node v . insertSpine us

deleteNode :: UiTreePath -> Map UUID (UiTree v) -> Map UUID (UiTree v)
deleteNode (p :| [])     = M.delete p
deleteNode (p :| (a:as)) = M.adjust (& _Node . _2 %~ deleteNode (a:|as)) p

priorityElt :: MonadWidget t m => UUID -> Dynamic t (UiTree T.Text) -> m (Event t UiTreeEvent)
priorityElt u = (switchHold never =<<) . dyn . fmap (treeWidget $ pure u)
  where
    treeWidget :: MonadWidget t m => NonEmpty UUID -> UiTree T.Text -> m (Event t UiTreeEvent)
    treeWidget uuids (Leaf v)   = el "li" $ do
      text v
      d <- deleteB uuids
      a <- addB (toList uuids)
      pure $ leftmost [d,a]
    treeWidget uuids (Node v m) = el "li" $ do
      text v
      d <- deleteB uuids
      el "ul" $ do
        es <- traverse (\(u,t) -> treeWidget (NEL.cons u uuids) t) $ M.toList $ m
        thisAdd <- el "li" $ addB (toList uuids)
        pure $ leftmost (thisAdd : d : es)

addB :: MonadWidget t m => [UUID] -> m (Event t UiTreeEvent)
addB uuids = (UiTreeAdd uuids <$) <$> buttonClass "add" "+"
deleteB :: MonadWidget t m => UiTreePath -> m (Event t UiTreeEvent)
deleteB uuids = (UiTreeDelete uuids <$) <$> buttonClass "delete" "-"

buttonClass :: MonadWidget t m => T.Text -> T.Text -> m (Event t ())
buttonClass c t = do
  (e,_) <- elClass' "button" c $ text t
  pure $ domEvent Click e