JS Frameworks Benchmark for Deku

Main.purs

module Main where

import Prelude

import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Monad.ST.Class (liftST)
import Data.Array ((!!), (..))
import Data.Array as Array
import Data.Array.ST as STArray
import Data.Foldable (for_, intercalate)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested ((/\))
import Deku.Control (text_)
import Deku.Core (Nut)
import Deku.DOM (Attribute)
import Deku.DOM as D
import Deku.DOM as DOM
import Deku.DOM.Attributes as DA
import Deku.DOM.Combinators (templated, templatedMap_, templated_)
import Deku.DOM.Listeners as DL
import Deku.Do as Deku
import Deku.Hooks ((<#~>))
import Deku.Hooks as DH
import Deku.Pursx (pursx, template)
import Deku.Toplevel (runInBody)
import Effect (Effect, foreachE)
import Effect.Random (randomInt)
import FRP.Event (fold, keepLatest, mapAccum)
import FRP.Poll (Poll, merge, mergePure)
import Foreign.Object as Object
import Record (union)

randomAdjectives :: Array String
randomAdjectives =
  [ "pretty"
  , "large"
  , "big"
  , "small"
  , "tall"
  , "short"
  , "long"
  , "handsome"
  , "plain"
  , "quaint"
  , "clean"
  , "elegant"
  , "easy"
  , "angry"
  , "crazy"
  , "helpful"
  , "mushy"
  , "odd"
  , "unsightly"
  , "adorable"
  , "important"
  , "inexpensive"
  , "cheap"
  , "expensive"
  , "fancy"
  ]

randomColors :: Array String
randomColors =
  [ "red"
  , "yellow"
  , "blue"
  , "green"
  , "pink"
  , "brown"
  , "purple"
  , "brown"
  , "white"
  , "black"
  , "orange"
  ]

randomNouns :: Array String
randomNouns =
  [ "table"
  , "chair"
  , "house"
  , "bbq"
  , "desk"
  , "car"
  , "pony"
  , "cookie"
  , "sandwich"
  , "burger"
  , "pizza"
  , "mouse"
  , "keyboard"
  ]

makeRow
  :: forall r
   . { appendRows :: Poll (Array (Tuple Int String))
     , swap :: Poll (Tuple String Int)
     , rowbox :: Poll String
     , selectbox :: Poll String
     , remove :: Poll String
     , unselectbox :: Poll String
     , selectMe :: Int -> Effect Unit
     , removeMe :: ((Int -> Effect Unit) -> Effect Unit) -> Effect Unit
     , arr :: Array (Tuple Int String)
     | r
     }
  -> Nut
makeRow { selectMe, arr, remove, removeMe, swap, appendRows, rowbox, selectbox, unselectbox } = Deku.do
  template @"""<tr ~sel~ ><td class="col-md-1"> ~num~ </td><td class="col-md-4"><a ~select~ class="lbl">~label~ ~excl~</a></td><td class="col-md-1"><a ~rm~ class="remove"><span class="remove glyphicon glyphicon-remove" aria-hidden="true"></span></a></td><td class="col-md-6"></td></tr>"""
    $ merge
        [ templated_ selectbox { sel: [ DA.klass_ "danger" ] }
        , templated_ unselectbox { sel: [ DA.unset DA.klass $ pure unit ] }
        , templated_ remove { remove: unit }
        , templatedMap_ swap { sendTo: _ }
        , mapAccum
            ( \a b -> case Object.lookup b a of
                Nothing -> Tuple (Object.insert b woah'woah'woah a) (Tuple b woah'woah'woah)
                Just e -> let updated = e <> woah'woah'woah in Tuple (Object.insert b updated a) (Tuple b updated)
            )
            Object.empty
            rowbox `templatedMap_` (pure >>> { excl: _ })
        , merge [ mergePure arr, keepLatest (map mergePure appendRows) ] `templated show` \i s ->
            { num: pure $ show (i + 1)
            , select: [ DL.click_ \_ -> selectMe i ]
            , label: pure $ s
            , rm: [ DL.click_ \_ -> removeMe \f -> f i ]
            }
        ]
  where
  woah'woah'woah = " !!!"

makeTable
  :: { rowBuilder :: Poll RowBuilder
     , appendRows :: Poll (Array (Tuple Int String))
     , swap :: Poll (Tuple String Int)
     , pushToRow :: Int -> Effect Unit
     , remove :: Poll String
     , rowbox :: Poll String
     , selectbox :: Poll String
     , unselectbox :: Poll String
     , selectMe :: Int -> Effect Unit
     , removeMe :: ((Int -> Effect Unit) -> Effect Unit) -> Effect Unit
     }
  -> Nut
makeTable i = i.rowBuilder <#~> case _ of
  AddRows arr -> makeRow $ i `union` { arr }
  Clear -> mempty

data RowBuilder = AddRows (Array (Tuple Int String)) | Clear

rando :: Array String -> Effect String
rando a = do
  ri <- randomInt 0 (Array.length a)
  pure $ fromMaybe "foo" (a !! ri)

genRows :: Int -> Int -> Effect (Array (Tuple Int String))
genRows offset n = do
  arr <- liftST $ STArray.new
  foreachE (0 .. (n - 1)) \i -> do
    adjective <- rando randomAdjectives
    color <- rando randomColors
    noun <- rando randomNouns
    let label = intercalate " " [ adjective, color, noun ]
    liftST $ void $ STArray.push (Tuple (offset + i) label) arr
  liftST $ STArray.freeze arr

data RowTransform = Start Int Int | Add Int Int | Swap | Delete Int | ClearRows

doRowTransform :: Array Int -> RowTransform -> Array Int
doRowTransform a (Add i o) = a <> (i .. (o - 1))
doRowTransform _ (Start i o) = (i .. (o - 1))
doRowTransform a Swap = fromMaybe a do
  l <- a !! 1
  r <- a !! 998
  o <- Array.updateAt 998 l a
  Array.updateAt 1 r o
doRowTransform a (Delete v) = Array.delete v a
doRowTransform _ ClearRows = []

rowBuilderToN :: Int -> RowBuilder -> Int
rowBuilderToN b (AddRows arr) = Array.length arr + b
rowBuilderToN _ Clear = 0

main :: Effect Unit
main = runInBody Deku.do
  setRowBuilder /\ rowBuilder <- DH.useState'
  setAppendRows /\ appendRows <- DH.useState'
  incrementRows /\ nRowsRaw <- DH.useState'
  nRows <- DH.useRant (fold add 0 nRowsRaw)
  nRowsRef <- DH.useRef 0 nRows
  setRowTransformer /\ rowTransformerRaw <- DH.useState'
  rowTransformer <- DH.useRant (fold doRowTransform [] rowTransformerRaw)
  rowTransformerRef <- DH.useRef [] rowTransformer
  setSwap /\ swap <- DH.useState'
  pushToRemove /\ remove <- DH.useState'
  pushToRow /\ rowbox <- DH.useState'
  pushToSelect /\ selectbox <- DH.useState'
  pushToUnselect /\ unselectbox <- DH.useState'
  setCurrentSelection /\ currentSelection <- DH.useHot Nothing
  selectionRef <- DH.useRef Nothing currentSelection
  let
    selectMe index = do
      pushToSelect $ Tuple (show index) unit
      s <- selectionRef
      setCurrentSelection $ Just index
      for_ s \i -> do
        pushToUnselect (Tuple (show i) unit)
    removeMe rmEffect = do
      rmEffect \i -> do
        setRowTransformer $ Delete i
        pushToRemove $ Tuple (show i) unit
      setCurrentSelection Nothing
  let
    adder b f n = do
      r <- nRowsRef
      rows <- genRows r n
      setRowTransformer $ (if b then Start else Add) r (r + n)
      incrementRows n *> f rows
  let rowAdder = adder true (setRowBuilder <<< AddRows)
  pursx @Body
    { table: makeTable
        { selectMe
        , removeMe
        , remove: map fst remove
        , selectbox: map fst selectbox
        , unselectbox: map fst unselectbox
        , rowbox: map fst rowbox
        , swap
        , rowBuilder
        , appendRows
        , pushToRow: \i -> pushToRow (Tuple (show i) unit)
        }
    , c1000: DL.click_ \_ -> rowAdder 1000
    , c10000: DL.click_ \_ -> rowAdder 10000
    , append: DL.click_ \_ -> do
        a <- rowTransformerRef
        if Array.null a then rowAdder 1000 else adder false setAppendRows 1000
    , clear: DL.click_ \_ -> do
        setRowTransformer ClearRows
        setRowBuilder Clear
    , swap: DL.click_ \_ -> do
        a <- rowTransformerRef
        let
          swappies = ado
            l <- a !! 1
            r <- a !! 998
            in Tuple l r
        for_ swappies \(Tuple l r) -> do
          setSwap $ Tuple (show r) 1
          setSwap $ Tuple (show l) 998
        setRowTransformer Swap
    , update: DL.runOn DL.click $ rowTransformer <#>
        \arr -> do
          let
            go { i } = case arr !! i of
              Nothing -> pure $ Done unit
              Just head -> pushToRow (Tuple (show head) unit) $> Loop { i: i + 10 }
          tailRecM go { i: 0 }
    }

rowTemplate
  :: { label :: Nut
     , n :: Int
     , selected :: Poll Unit
     , unselected :: Poll Unit
     , select :: Poll (Attribute (DOM.HTMLAnchorElement ()))
     , remove :: Poll (Attribute (DOM.HTMLAnchorElement ()))
     }
  -> Nut
rowTemplate { n, select, selected, unselected, label, remove } = D.tr
  [ DA.klass $ selected $> "danger"
  , DA.unset DA.klass (unselected $> unit)
  ]
  [ D.td [ DA.klass_ "col-md-1" ] [ text_ $ show (n + 1) ]
  , D.td [ DA.klass_ "col-md-4" ]
      [ D.a [ select, DA.klass_ "lbl" ] [ label ] ]
  , D.td [ DA.klass_ "col-md-1" ]
      [ D.a [ remove, DA.klass_ "remove" ]
          [ D.span
              [ DA.klass_ "remove glyphicon glyphicon-remove"
              , DA.ariaHidden_ "true"
              ]
              []
          ]
      ]
  , D.td [ DA.klass_ "col-md-6" ] []
  ]

type Body =
  """<div id="main">
    <div class="container">
        <div class="jumbotron">
            <div class="row">
                <div class="col-md-6">
                    <h1>Deku-"keyed"</h1>
                </div>
                <div class="col-md-6">
                    <div class="row">
                        <div class="col-sm-6 smallpad">
                            <button ~c1000~ type="button" class="btn btn-primary btn-block" id="run">Create 1,000 rows</button>
                        </div>
                        <div class="col-sm-6 smallpad">
                            <button ~c10000~ type="button" class="btn btn-primary btn-block" id="runlots">Create 10,000 rows</button>
                        </div>
                        <div class="col-sm-6 smallpad">
                            <button ~append~ type="button" class="btn btn-primary btn-block" id="add">Append 1,000 rows</button>
                        </div>
                        <div class="col-sm-6 smallpad">
                            <button ~update~ type="button" class="btn btn-primary btn-block" id="update">Update every 10th row</button>
                        </div>
                        <div class="col-sm-6 smallpad">
                            <button ~clear~ type="button" class="btn btn-primary btn-block" id="clear">Clear</button>
                        </div>
                        <div class="col-sm-6 smallpad">
                            <button ~swap~ type="button" class="btn btn-primary btn-block" id="swaprows">Swap Rows</button>
                        </div>
                    </div>
                </div>
            </div>
        </div>
        <table class="table table-hover table-striped test-data">
          <tbody>
             ~table~
          </tbody>
        </table>
        <span class="preloadicon glyphicon glyphicon-remove" aria-hidden="true"></span>
    </div>
</div>"""