@@ -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
7+import Data.Monoid
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
13+import Reflex.Dom
14+import Data.FastMutableIntMap
15+import System.Random
16+
17+type RNG = StdGen
18+type Entropy = Int
19+type RowNumber = Int
20+type RowIndex = Int
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
25+
26+main :: IO ()
27+main = do
28+ seed <- randomIO
29+ mainWidgetWithHead' (\_ -> headW, \_ -> bodyW seed)
30+
31+titleW :: MonadWidget t m => m ()
32+titleW = text "Reflex-dom keyed"
33+
34+headW :: MonadWidget t m => m ()
35+headW = do
36+ el "title" titleW
37+ elAttr "link" ("href" =: "/css/currentStyle.css" <> "rel" =: "stylesheet") blank
38+
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)
50+ ]
51+
52+ let initial = Model { rng = mkStdGen seed, nextNum = 1, selection = Nothing }
53+ let events = leftmost $ fmap (foldl1 sequenceSteps) rowEvents : buttonEvents
54+
55+ rowEvents <- tableW dynMT
56+
57+ dynMT <- mapAccum_ step (initial, empty) events
58+
59+ blank
60+
61+type Step = (Model, Table) -> (Model, TableDiff)
62+
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)
68+ in (mb, tdb <> tda)
69+
70+step :: (Model, Table) -> Step -> ((Model, Table), TableDiff)
71+step (m, t) f = ((m', t'), dt)
72+ where
73+ (m', dt) = f (m, t)
74+ t' = applyAlways dt t
75+
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)
78+ where
79+ buttonW' attrs = do
80+ (b, _) <- elAttr' "button" attrs $ text txt
81+ pure $ val <$ domEvent Click b
82+
83+tableW :: MonadWidget t m => Event t TableDiff -> m (Event t (IntMap Step))
84+tableW diff = do
85+ elClass "table" "table table-hover table-striped test-data" $ do
86+ el "tbody" $ do
87+ (v0, v') <- traverseIntMapWithKeyWithAdjust (\_ -> rowW) empty diff
88+ rowEvents <- holdIncremental v0 v'
89+ return $ mergeIntIncremental rowEvents
90+
91+rowW :: MonadWidget t m => Row -> m (Event t Step)
92+rowW row = elClass "tr" (if selected row then "danger" else "") $
93+ do
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]
100+ where
101+ tagClick f el = f row <$ (domEvent Click el)
102+
103+deleteW :: MonadWidget t m => m ()
104+deleteW = el "a" $ elAttr "span" ("aria-hidden" =: "true" <> "class" =: "glyphicon glyphicon-remove") blank
105+
106+
107+{- Domain logic -}
108+clearRows :: (Model, Table) -> (Model, TableDiff)
109+clearRows (m, t) = (m { selection = Nothing }, PatchIntMap $ Nothing <$ t)
110+
111+updateRows :: (RowIndex -> Bool) -> (Text -> Text) -> (Model, Table) -> (Model, TableDiff)
112+updateRows p f (m, t) = (m, PatchIntMap $ Just . update <$> targets)
113+ where
114+ targets = fromList . filterByIndex p . assocs $ t
115+ update = \r -> r { txt = f $ txt r }
116+
117+filterByIndex :: (Int -> Bool) -> [a] -> [a]
118+filterByIndex p = map snd . filter (\(i, _) -> p i) . zip [0..]
119+
120+swapRows :: (RowIndex, RowIndex) -> (Model, Table) -> (Model, TableDiff)
121+swapRows (a, b) (m, t) = (m, PatchIntMap $ point a b <> point b a)
122+ where
123+ point x y = singleton (fst (val x)) $ Just $ snd $ val y
124+ val = (assocs t !!)
125+
126+selectRow :: Row -> (Model, Table) -> (Model, TableDiff)
127+selectRow r (m, t) = (m { selection = Just r}, PatchIntMap $ dr <> ds)
128+ where
129+ dr = sel True r
130+ ds = maybe empty (sel False) $ selection m
131+ sel b r' = singleton (num r') $ Just r' { selected = b }
132+
133+deleteRow :: Row -> (Model, Table) -> (Model, TableDiff)
134+deleteRow r (m, t) = (m { selection = mfilter (/= r) (selection m) }, PatchIntMap $ singleton (num r) Nothing)
135+
136+resetRows :: Int -> (Model, Table) -> (Model, TableDiff)
137+resetRows n (m, t) = (m'', dt <> dt')
138+ where
139+ (m', dt ) = addRows n (m, t)
140+ (m'', dt') = clearRows (m', t)
141+
142+appendRows :: Int -> (Model, Table) -> (Model, TableDiff)
143+appendRows n (m, t) = addRows n (m, t)
144+
145+addRows :: Int -> (Model, Table) -> (Model, TableDiff)
146+addRows count (m, t) = (m { rng = rng', nextNum = nextNum' }, PatchIntMap diff)
147+ where
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
151+
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')))
154+
155+randomName :: Entropy -> Text
156+randomName e = T.intercalate " " $ (`modIndex` e) <$> [adjectives, colours, nouns]
157+
158+-- | Index into a Vector, modulo its length
159+--
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
163+
164+adjectives, colours, nouns :: Vector Text
165+adjectives = Vector.fromList
166+ [ "pretty"
167+ , "large"
168+ , "big"
169+ , "small"
170+ , "tall"
171+ , "short"
172+ , "long"
173+ , "handsome"
174+ , "plain"
175+ , "quaint"
176+ , "clean"
177+ , "elegant"
178+ , "easy"
179+ , "angry"
180+ , "crazy"
181+ , "helpful"
182+ , "mushy"
183+ , "odd"
184+ , "unsightly"
185+ , "adorable"
186+ , "important"
187+ , "inexpensive"
188+ , "cheap"
189+ , "expensive"
190+ , "fancy"
191+ ]
192+colours = Vector.fromList
193+ [ "red"
194+ , "yellow"
195+ , "blue"
196+ , "green"
197+ , "pink"
198+ , "brown"
199+ , "purple"
200+ , "brown"
201+ , "white"
202+ , "black"
203+ , "orange"
204+ ]
205+nouns = Vector.fromList
206+ [ "table"
207+ , "chair"
208+ , "house"
209+ , "bbq"
210+ , "desk"
211+ , "car"
212+ , "pony"
213+ , "cookie"
214+ , "sandwich"
215+ , "burger"
216+ , "pizza"
217+ , "mouse"
218+ , "keyboard"
219+ ]