@@ -0,0 +1,256 @@
1+{-# LANGUAGE RecursiveDo #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE FlexibleContexts #-}
7+{-# LANGUAGE Rank2Types #-}
8+{-# OPTIONS_GHC -ddump-simpl -ddump-rules -ddump-spec -ddump-to-file -dsuppress-coercions -dsuppress-idinfo #-}
9+module Main (main) where
10+
11+import Control.Monad.State
12+import Data.Monoid
13+import Data.Text (Text)
14+import qualified Data.Text as T
15+import Reflex.Dom
16+import System.Random
17+import qualified Data.Map as Map
18+import Data.Dependent.Map (DMap (..), DSum (..))
19+import qualified Data.Dependent.Map as DMap
20+import Data.Functor.Misc
21+import Data.Functor.Identity
22+import Data.Functor.Compose
23+import Data.IORef
24+import GHCJS.DOM.Types (JSM)
25+import qualified Data.Some as Some
26+import Data.Functor.Constant
27+import Data.IntMap.Strict (IntMap)
28+import qualified Data.IntMap.Strict as IntMap
29+import Data.FastMutableIntMap
30+
31+import qualified GHCJS.DOM.Element as DOM
32+import qualified GHCJS.DOM.Types as DOM
33+
34+{-# SPECIALIZE makeElement :: forall er a. Text -> ElementConfig er (SpiderTimeline Global) GhcjsDomSpace -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) a -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) ((Element er GhcjsDomSpace (SpiderTimeline Global), a), DOM.Element) #-}
35+
36+{-# SPECIALIZE wrap :: forall er. RawElement GhcjsDomSpace -> RawElementConfig er (SpiderTimeline Global) GhcjsDomSpace -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (Element er GhcjsDomSpace (SpiderTimeline Global)) #-}
37+
38+{- SPECIALIZE mapDMapWithAdjustImpl :: forall k v v' p.
39+ ( (forall a. k a -> Compose ((,) (Bool, Event (SpiderTimeline Global) ())) v a -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (v' a))
40+ -> DMap k (Compose ((,) (Bool, Event (SpiderTimeline Global) ())) v)
41+ -> Event (SpiderTimeline Global) (p k (Compose ((,) (Bool, Event (SpiderTimeline Global) ())) v))
42+ -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (DMap k v', Event (SpiderTimeline Global) (p k v'))
43+ )
44+ -> ((forall a. v a -> Compose ((,) (Bool, Event (SpiderTimeline Global) ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event (SpiderTimeline Global) ())) v))
45+ -> (forall a. k a -> v a -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (v' a))
46+ -> DMap k v
47+ -> Event (SpiderTimeline Global) (p k v)
48+ -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (DMap k v', Event (SpiderTimeline Global) (p k v'))
49+ #-}
50+
51+{-# SPECIALIZE mapIntMapWithAdjustImpl :: forall v v'.
52+ ( (IntMap.Key -> ((Bool, Event (SpiderTimeline Global) ()), v) -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) v')
53+ -> IntMap ((Bool, Event (SpiderTimeline Global) ()), v)
54+ -> Event (SpiderTimeline Global) (PatchIntMap ((Bool, Event (SpiderTimeline Global) ()), v))
55+ -> (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))
56+ )
57+ -> (IntMap.Key -> v -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) v')
58+ -> IntMap v
59+ -> Event (SpiderTimeline Global) (PatchIntMap v)
60+ -> PostBuildT (SpiderTimeline Global) (ImmediateDomBuilderT Spider (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))
61+ #-}
62+
63+{-# SPECIALIZE append :: DOM.DocumentFragment -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) () #-}
64+
65+{-# SPECIALIZE drawChildUpdate :: forall k v' a. ImmediateDomBuilderEnv (SpiderTimeline Global) -> (IORef (ChildReadyState k) -> JSM ()) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (v' a) -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a) #-}
66+
67+{- SPECIALIZE traverseDMapWithKeyWithAdjust' :: forall v v'. (forall a. (Const2 Int ()) a -> v a -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (v' a)) -> DMap (Const2 Int ()) v -> Event (SpiderTimeline Global) (PatchDMap (Const2 Int ()) v) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (DMap (Const2 Int ()) v', Event (SpiderTimeline Global) (PatchDMap (Const2 Int ()) v')) #-}
68+
69+{-# SPECIALIZE traverseIntMapWithKeyWithAdjust' :: forall v v'. (IntMap.Key -> v -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) v') -> IntMap v -> Event (SpiderTimeline Global) (PatchIntMap v) -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v')) #-}
70+
71+{- SPECIALIZE hoistTraverseWithKeyWithAdjust :: forall v v'.
72+ (forall vv vv'.
73+ (forall a. (Const2 Int ()) a -> vv a -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (vv' a))
74+ -> DMap (Const2 Int ()) vv
75+ -> Event (SpiderTimeline Global) (PatchDMap (Const2 Int ()) vv)
76+ -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (DMap (Const2 Int ()) vv', Event (SpiderTimeline Global) (PatchDMap (Const2 Int ()) vv'))
77+ ) -- ^ The base monad's traversal
78+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> PatchDMap (Const2 Int ()) vv -> PatchDMap (Const2 Int ()) vv') -- ^ A way of mapping over the patch type
79+ -> (PatchDMap (Const2 Int ()) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState (Const2 Int ())))) v') -> DMap (Const2 Int ()) (Constant (IORef (ChildReadyState (Const2 Int ())))) -> IO (DMap (Const2 Int ()) (Constant (IORef (ChildReadyState (Const2 Int ())))))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
80+ -> (IORef (Map.Map (Some.Some (Const2 Int ())) DOM.Text) -> IORef DOM.Text -> PatchDMap (Const2 Int ()) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState (Const2 Int ())))) v') -> JSM ()) -- ^ Apply a patch to the DOM
81+ -> (forall a. (Const2 Int ()) a -> v a -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (v' a))
82+ -> DMap (Const2 Int ()) v
83+ -> Event (SpiderTimeline Global) (PatchDMap (Const2 Int ()) v)
84+ -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (DMap (Const2 Int ()) v', Event (SpiderTimeline Global) (PatchDMap (Const2 Int ()) v'))
85+ #-}
86+
87+{-# SPECIALIZE hoistTraverseIntMapWithKeyWithAdjust :: forall v v'.
88+ ( (IntMap.Key -> v -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'))
89+ -> IntMap v
90+ -> Event (SpiderTimeline Global) (PatchIntMap v)
91+ -> RequesterT (SpiderTimeline Global) JSM Identity (TriggerEventT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global)))) (IntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v'), Event (SpiderTimeline Global) (PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v')))
92+ ) -- ^ The base monad's traversal
93+ -> (PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> IntMap (IORef ChildReadyStateInt) -> IO (IntMap (IORef ChildReadyStateInt))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state
94+ -> (IORef (IntMap DOM.Text) -> IORef DOM.Text -> PatchIntMap (DOM.DocumentFragment, DOM.Text, IORef ChildReadyStateInt, v') -> JSM ()) -- ^ Apply a patch to the DOM
95+ -> (IntMap.Key -> v -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) v')
96+ -> IntMap v
97+ -> Event (SpiderTimeline Global) (PatchIntMap v)
98+ -> ImmediateDomBuilderT (SpiderTimeline Global) (WithJSContextSingleton () (PerformEventT Spider (SpiderHost Global))) (IntMap v', Event (SpiderTimeline Global) (PatchIntMap v'))
99+ #-}
100+
101+--{-
102+main :: IO ()
103+main = mainWidget' $ do
104+ create1000 <- button "Create 1,000 rows"
105+ let row k _ = el "li" $ text $ T.pack $ show k
106+ el "ul" $ traverseIntMapWithKeyWithAdjust row IntMap.empty $ PatchIntMap (IntMap.fromDistinctAscList [(x, Just ()) | x <- [1 :: Int .. 1000]]) <$ create1000
107+ return ()
108+--}
109+
110+
111+{-
112+main :: IO ()
113+main = do
114+ mainWidget' $ do
115+ create1000 <- button "Create 1,000 rows"
116+ partialUpdate <- button "Update every 10th row"
117+ elClass "table" "table table-hover table-striped test-data" $ el "tbody" $ do
118+ --runWithReplace blank $ forM_ [1..1000] row <$ create1000
119+ rec let u = leftmost
120+ [ PatchIntMap (IntMap.fromDistinctAscList [(x, Just ()) | x <- [1..1000]]) <$ create1000
121+ , PatchIntMap (IntMap.fromDistinctAscList [(x, Just ()) | x <- [1, 11..1000]]) <$ partialUpdate
122+ , PatchIntMap <$> deletes
123+ ]
124+ (_, deletes) <- runEventWriterT $ traverseIntMapWithKeyWithAdjust (\k _ -> row k) mempty u
125+ return ()
126+
127+row :: MonadWidget t m => Int -> EventWriterT t (IntMap (Maybe ())) m ()
128+row rowNum = el "tr" $ do
129+ elClass "td" "col-md-1" $ text $ T.pack $ show rowNum
130+ (sel, _) <- elClass' "td" "col-md-4" $ el "a" $ text "asdf"
131+ (del, _) <- elClass' "td" "col-md-1" deleteButton
132+ tellEvent $ IntMap.singleton rowNum Nothing <$ domEvent Click del
133+ elClass "td" "col-md-6" blank
134+
135+deleteButton :: MonadWidget t m => m ()
136+deleteButton = el "a" $ elAttr "span" ("aria-hidden" =: "true" <> "class" =: "glyphicon glyphicon-remove") $ text "X"
137+
138+--}
139+
140+--
141+{-
142+type RNG = StdGen
143+type Entropy = Int
144+type RowPosition = Int
145+type RowNumber = Int
146+data Row = Row { pos :: RowPosition, num :: RowNumber , txt :: Text } deriving (Eq, Show)
147+type Table = Map RowPosition Row
148+data Model = Model { rng :: RNG, table :: Table, nextNum :: RowNumber, selected :: Maybe Row } deriving Show
149+
150+{- Widgets -}
151+
152+titleW :: MonadWidget t m => m ()
153+titleW = text "Reflex-Dom"
154+
155+headW :: MonadWidget t m => m ()
156+headW = do
157+ el "title" titleW
158+ elAttr "link" ("href" =: "/css/currentStyle.css" <> "rel" =: "stylesheet") blank
159+
160+bodyW :: MonadWidget t m => Entropy -> m ()
161+bodyW seed = divClass "main" $ divClass "container" $ mdo
162+ let initial = Model { rng = mkStdGen seed, table = empty, nextNum = 1, selected = Nothing }
163+ dynModel <- foldDyn ($) initial $ mergeWith (.) $ rowEvents : buttonEvents
164+
165+ buttonEvents :: [Event t (Model -> Model)] <- divClass "jumbotron" $ divClass "row" $ do
166+ divClass "col-md-6" $ el "h1" titleW
167+ divClass "col-md-6" $ divClass "row" $ sequence [
168+ buttonW "run" "Create 1,000 rows" $ createRows 1000,
169+ buttonW "runlots" "Create 10,000 rows" $ createRows 10000,
170+ buttonW "add" "Append 1,000 rows" $ appendRows 1000,
171+ buttonW "update" "Update every 10th row" $ updateRows (\p -> mod p 10 == 0) (<> " !!!"),
172+ buttonW "clear" "Clear" $ clearRows,
173+ buttonW "swaprows" "Swap Rows" $ swapRows (4, 9)
174+ ]
175+
176+ rowEvents' <- tableW dynModel
177+ let rowEvents = foldl (.) id <$> rowEvents'
178+
179+ blank
180+
181+buttonW :: MonadWidget t m => Text -> Text -> a -> m (Event t a)
182+buttonW id txt val = divClass "col-sm-6 smallpad" $ buttonW' ("class" =: "btn btn-primary btn-block" <> "id" =: id)
183+ where
184+ buttonW' attrs = do
185+ (b, _) <- elAttr' "button" attrs $ text txt
186+ pure $ val <$ domEvent Click b
187+
188+tableW :: MonadWidget t m => Dynamic t Model -> m (Event t (Map RowPosition (Model -> Model)))
189+tableW dynM =
190+ elClass "table" "table table-hover table-striped test-data"
191+ $ el "tbody"
192+ $ listViewWithKey (table <$> dynM) (\_ dynRow -> rowW (selectedIs <$> dynM <*> dynRow) dynRow)
193+ where
194+ selectedIs m r = selected m == Just r
195+
196+rowW :: MonadWidget t m => Dynamic t Bool -> Dynamic t Row -> m (Event t (Model -> Model))
197+rowW dynSelected dynRow = elDynClass "tr" trClass $
198+ do
199+ elClass "td" "col-md-1". dynText $ pack . show . num <$> dynRow
200+ (sel, _) <- elClass' "td" "col-md-4". el "a" . dynText $ txt <$> dynRow
201+ (del, _) <- elClass' "td" "col-md-1" deleteW
202+ elClass "td" "col-md-6" blank
203+ pure $ mergeWith (.) $ zipWith tagClick [selectRow, deleteRow] [sel, del]
204+ where
205+ trClass = (\b -> if b then "danger" else "") <$> dynSelected
206+ tagClick f el = (tag . current) (f <$> dynRow) (domEvent Click el)
207+
208+
209+{- Domain logic -}
210+
211+clearRows :: Model -> Model
212+clearRows (Model {..}) = Model { table = empty, .. }
213+
214+updateRows :: (RowPosition -> Bool) -> (Text -> Text) -> Model -> Model
215+updateRows p f (Model {..}) = Model { table = (update <$> targets) <> table, .. }
216+ where
217+ targets = filterWithKey (const . p) table
218+ update = \(Row{..}) -> Row { txt = f txt, ..}
219+
220+swapRows :: (RowPosition, RowPosition) -> Model -> Model
221+swapRows (a,b) (Model {..}) = Model { table = (a =: val b) <> (b =: val a) <> table, .. }
222+ where val = (table !)
223+
224+selectRow, deleteRow :: Row -> Model -> Model
225+selectRow r m = m { selected = Just r }
226+deleteRow r (Model {..}) = Model { table = shifted table, .. }
227+ where
228+ shifted = fromList . zipWith update [0..] . elems . delete (pos r)
229+ update p (Row{..}) = (p, Row { pos = p, .. })
230+
231+createRows, appendRows :: Int -> Model -> Model
232+createRows = newRows False
233+appendRows = newRows True
234+
235+newRows :: Bool -> Int -> Model -> Model
236+newRows keepOld count (Model {..}) = Model { rng = rng', table = table', nextNum = nextNum', .. }
237+ where
238+ nextPos = if keepOld then length table else 0
239+ rowsST = sequence (rowST <$ [0..count-1])
240+ (rows, (nextPos', nextNum', rng')) = runState rowsST (nextPos, nextNum, rng)
241+ combine = if keepOld then (<>) else \_ new -> new
242+ table' = fromList . zip [0..] $ combine (elems table) rows
243+
244+rowST :: State (RowPosition, RowNumber, RNG) Row
245+rowST = state (\(p,n,g) -> let (e, g') = next g in (Row {pos = p, num = n, txt = randomName e}, (p+1,n+1,g')))
246+
247+randomName :: Entropy -> Text
248+randomName e = intercalate " " $ (!!% e) <$> [adjectives, colours, nouns]
249+ where xs !!% n = xs !! mod n (length xs)
250+
251+adjectives,colours,nouns :: [Text]
252+adjectives = ["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"]
253+colours = ["red", "yellow", "blue", "green", "pink", "brown", "purple", "brown", "white", "black", "orange"]
254+nouns = ["table", "chair", "house", "bbq", "desk", "car", "pony", "cookie", "sandwich", "burger", "pizza", "mouse", "keyboard"]
255+
256+-}