@@ -0,0 +1,219 @@
1+{-# LANGUAGE RecursiveDo #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# OPTIONS_GHC -ddump-simpl -ddump-rules -ddump-spec -ddump-to-file -dsuppress-coercions -dsuppress-idinfo #-}
6+import Control.Monad.State
8+import Data.IntMap (IntMap, assocs, elems, empty, fromList, size, singleton)
9+import Data.Text (Text)
10+import qualified Data.Text as T
11+import Data.Vector (Vector)
12+import qualified Data.Vector as Vector
14+import Data.FastMutableIntMap
21+data Row = Row { num :: RowNumber, txt :: Text, selected :: Bool } deriving (Eq, Show)
22+type Table = IntMap Row
23+data Model = Model { rng :: RNG, nextNum :: RowNumber, selection :: Maybe Row } deriving Show
24+type TableDiff = PatchIntMap Row
29+ mainWidgetWithHead' (\_ -> headW, \_ -> bodyW seed)
31+titleW :: MonadWidget t m => m ()
32+titleW = text "Reflex-dom keyed"
34+headW :: MonadWidget t m => m ()
37+ elAttr "link" ("href" =: "/css/currentStyle.css" <> "rel" =: "stylesheet") blank
39+bodyW :: forall t m. MonadWidget t m => Entropy -> m ()
40+bodyW seed = divClass "main" $ divClass "container" $ mdo
41+ buttonEvents <- divClass "jumbotron" $ divClass "row" $ do
42+ divClass "col-md-6" $ el "h1" titleW
43+ divClass "col-md-6" $ divClass "row" $ sequence
44+ [ buttonW "run" "Create 1,000 rows" $ resetRows 1000
45+ , buttonW "runlots" "Create 10,000 rows" $ resetRows 10000
46+ , buttonW "add" "Append 1,000 rows" $ appendRows 1000
47+ , buttonW "update" "Update every 10th row" $ updateRows (\i -> mod i 10 == 0) (<> " !!!")
48+ , buttonW "clear" "Clear" $ clearRows
49+ , buttonW "swaprows" "Swap Rows" $ swapRows (4, 9)
52+ let initial = Model { rng = mkStdGen seed, nextNum = 1, selection = Nothing }
53+ let events = leftmost $ fmap (foldl1 sequenceSteps) rowEvents : buttonEvents
55+ rowEvents <- tableW dynMT
57+ dynMT <- mapAccum_ step (initial, empty) events
61+type Step = (Model, Table) -> (Model, TableDiff)
63+sequenceSteps :: Step -> Step -> Step
64+sequenceSteps a b (m, t) =
65+ let (ma, tda) = a (m, t)
66+ ta = applyAlways tda t
67+ (mb, tdb) = b (ma, ta)
70+step :: (Model, Table) -> Step -> ((Model, Table), TableDiff)
71+step (m, t) f = ((m', t'), dt)
74+ t' = applyAlways dt t
76+buttonW :: MonadWidget t m => Text -> Text -> a -> m (Event t a)
77+buttonW id txt val = divClass "col-sm-6 smallpad" $ buttonW' ("class" =: "btn btn-primary btn-block" <> "id" =: id)
80+ (b, _) <- elAttr' "button" attrs $ text txt
81+ pure $ val <$ domEvent Click b
83+tableW :: MonadWidget t m => Event t TableDiff -> m (Event t (IntMap Step))
85+ elClass "table" "table table-hover table-striped test-data" $ do
87+ (v0, v') <- traverseIntMapWithKeyWithAdjust (\_ -> rowW) empty diff
88+ rowEvents <- holdIncremental v0 v'
89+ return $ mergeIntIncremental rowEvents
91+rowW :: MonadWidget t m => Row -> m (Event t Step)
92+rowW row = elClass "tr" (if selected row then "danger" else "") $
94+ elClass "td" "col-md-1" $ do
95+ text $ T.pack $ show $ num row
96+ (sel, _) <- elClass' "td" "col-md-4". el "a" . text $ txt row
97+ (del, _) <- elClass' "td" "col-md-1" deleteW
98+ elClass "td" "col-md-6" blank
99+ pure . leftmost $ zipWith tagClick [selectRow, deleteRow] [sel, del]
101+ tagClick f el = f row <$ (domEvent Click el)
103+deleteW :: MonadWidget t m => m ()
104+deleteW = el "a" $ elAttr "span" ("aria-hidden" =: "true" <> "class" =: "glyphicon glyphicon-remove") blank
108+clearRows :: (Model, Table) -> (Model, TableDiff)
109+clearRows (m, t) = (m { selection = Nothing }, PatchIntMap $ Nothing <$ t)
111+updateRows :: (RowIndex -> Bool) -> (Text -> Text) -> (Model, Table) -> (Model, TableDiff)
112+updateRows p f (m, t) = (m, PatchIntMap $ Just . update <$> targets)
114+ targets = fromList . filterByIndex p . assocs $ t
115+ update = \r -> r { txt = f $ txt r }
117+filterByIndex :: (Int -> Bool) -> [a] -> [a]
118+filterByIndex p = map snd . filter (\(i, _) -> p i) . zip [0..]
120+swapRows :: (RowIndex, RowIndex) -> (Model, Table) -> (Model, TableDiff)
121+swapRows (a, b) (m, t) = (m, PatchIntMap $ point a b <> point b a)
123+ point x y = singleton (fst (val x)) $ Just $ snd $ val y
126+selectRow :: Row -> (Model, Table) -> (Model, TableDiff)
127+selectRow r (m, t) = (m { selection = Just r}, PatchIntMap $ dr <> ds)
130+ ds = maybe empty (sel False) $ selection m
131+ sel b r' = singleton (num r') $ Just r' { selected = b }
133+deleteRow :: Row -> (Model, Table) -> (Model, TableDiff)
134+deleteRow r (m, t) = (m { selection = mfilter (/= r) (selection m) }, PatchIntMap $ singleton (num r) Nothing)
136+resetRows :: Int -> (Model, Table) -> (Model, TableDiff)
137+resetRows n (m, t) = (m'', dt <> dt')
139+ (m', dt ) = addRows n (m, t)
140+ (m'', dt') = clearRows (m', t)
142+appendRows :: Int -> (Model, Table) -> (Model, TableDiff)
143+appendRows n (m, t) = addRows n (m, t)
145+addRows :: Int -> (Model, Table) -> (Model, TableDiff)
146+addRows count (m, t) = (m { rng = rng', nextNum = nextNum' }, PatchIntMap diff)
148+ rowsST = sequence (rowST <$ [0..count-1])
149+ (rows, (nextNum', rng')) = runState rowsST (nextNum m, rng m)
150+ diff = fromList . fmap (\r -> (num r, Just r)) $ rows
152+rowST :: State (RowNumber, RNG) Row
153+rowST = state (\(n, g) -> let (e, g') = next g in (Row {num = n, txt = randomName e, selected = False}, (n+1, g')))
155+randomName :: Entropy -> Text
156+randomName e = T.intercalate " " $ (`modIndex` e) <$> [adjectives, colours, nouns]
158+-- | Index into a Vector, modulo its length
160+-- WARNING: The vector must have length >= 1, and the index must be >= 0.
161+modIndex :: Vector a -> Int -> a
162+modIndex v n = Vector.unsafeIndex v $ n `mod` Vector.length v
164+adjectives, colours, nouns :: Vector Text
165+adjectives = Vector.fromList
192+colours = Vector.fromList
205+nouns = Vector.fromList