Skip to content

Instantly share code, notes, and snippets.

@benkolera
Last active August 14, 2018 05:32
Show Gist options
  • Save benkolera/f7036a550b9f0a86bfadb2786ec9ba7c to your computer and use it in GitHub Desktop.
Save benkolera/f7036a550b9f0a86bfadb2786ec9ba7c to your computer and use it in GitHub Desktop.
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
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment