@@ -1,31 +1,42 @@
1−{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes, TemplateHaskell #-}
2−
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE RecursiveDo #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
313module Reflex.Dom.Widget.Basic where
414
15+import Reflex.Dom.Builder.Class
516import Reflex.Dom.Class
617import Reflex.Dom.Internal.Foreign ()
718import Reflex.Dom.PostBuild.Class
8−import Reflex.Dom.Builder.Class
919
10−import Prelude hiding (mapM, mapM_, sequence, sequence_)
11−import Reflex
20+import Control.Arrow
21+import Control.Lens hiding (children, element)
22+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
23+import Data.Align
24+import Data.Default
25+import Data.Either
26+import Data.Foldable
1227import Data.Functor.Misc
1328import Data.Map (Map)
1429import qualified Data.Map as Map
15−import Data.Set (Set)
16−import qualified Data.Set as Set
17−import Data.Foldable
18−import Data.Traversable
19−import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
20−import Control.Lens hiding (element, children)
21−import Data.These
22−import Data.Align
2330import Data.Maybe
24−import Data.Default
25−import Data.Either
2631import Data.Semigroup
32+import Data.Set (Set)
33+import qualified Data.Set as Set
2734import Data.Text (Text)
2835import qualified Data.Text as T
36+import Data.These
37+import Data.Traversable
38+import Prelude hiding (mapM, mapM_, sequence, sequence_)
39+import Reflex
2940
3041widgetHoldInternal :: DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
3142widgetHoldInternal child0 child' = do
@@ -65,28 +76,27 @@ listHoldWithKey initialChildren modifyChildren buildChild = do
6576 & deleteSelf .~ delete
6677 ph <- placeholder myCfg
6778 result <- deletable delete $ buildChild k v
68− return $ ChildResult (result, (fmap (fmap Just) $ _placeholder_insertedAbove ph) <> (Map.singleton k Nothing <$ _placeholder_deleted ph)) --Note: we could also use the "deleted" output on deletable, if it had one; we're using this so that everything changes all at once, instead of deletions being prompt and insertions being delayed
79+ return $ ChildResult (result, (fmap Just <$> _placeholder_insertedAbove ph) <> (Map.singleton k Nothing <$ _placeholder_deletedSelf ph)) --Note: we could also use the "deleted" output on deletable, if it had one; we're using this so that everything changes all at once, instead of deletions being prompt and insertions being delayed
6980 rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild
7081 augmentedResults <- foldDyn applyMap initialAugmentedResults $ newInsertedBelow <> newInsertedAbove
71− let newInsertedAbove = switch $ fmap (mconcat . reverse . fmap (snd . unChildResult) . Map.elems) $ current augmentedResults
82+ let newInsertedAbove = switch $ mconcat . reverse . fmap (snd . unChildResult) . Map.elems <$> current augmentedResults
7283 belowAll <- placeholder $ def & placeholderConfig_insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Right ())
73− let newInsertedBelow = fmap (fmap Just) $ _placeholder_insertedAbove belowAll
74− mapDyn (fmap (fst . unChildResult)) augmentedResults
84+ let newInsertedBelow = fmap Just <$> _placeholder_insertedAbove belowAll
85+ return $ fmap (fmap (fst . unChildResult)) augmentedResults
7586
7687text :: DomBuilder t m => Text -> m ()
77−text t = void $ textNode $ def & textNodeConfig_contents .~ t
88+text t = void $ textNode $ def & textNodeConfig_initialContents .~ t
7889
79−dynText :: (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
90+dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
8091dynText t = do
8192 postBuild <- getPostBuild
82− _ <- widgetHoldInternal (return ()) $ text <$> leftmost
93+ void $ textNode $ (def :: TextNodeConfig t) & textNodeConfig_setContents .~ leftmost
8394 [ updated t
8495 , tag (current t) postBuild
8596 ]
86− return ()
8797
8898display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
89−display = dynText <=< mapDyn (T.pack . show)
99+display = dynText . fmap (T.pack . show)
90100
91101button :: DomBuilder t m => Text -> m (Event t ())
92102button t = do
@@ -101,7 +111,7 @@ dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
101111dyn child = do
102112 postBuild <- getPostBuild
103113 let newChild = leftmost [updated child, tag (current child) postBuild]
104− liftM snd $ widgetHoldInternal (return ()) newChild
114+ snd <$> widgetHoldInternal (return ()) newChild
105115
106116-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.
107117-- The returned Dynamic of widget results occurs when the Event does.
@@ -167,7 +177,7 @@ listWithKey' = listWithKeyShallowDiff
167177listWithKeyShallowDiff :: (Ord k, DomBuilder t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
168178listWithKeyShallowDiff initialVals valsChanged mkChild = do
169179 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
170− sentVals <- foldDyn applyMap Map.empty $ fmap (fmap (fmap (\_ -> ()))) valsChanged
180+ sentVals <- foldDyn applyMap Map.empty $ fmap (fmap void) valsChanged
171181 let relevantPatch patch _ = case patch of
172182 Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored
173183 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
@@ -178,10 +188,10 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do
178188-- | Create a dynamically-changing set of Event-valued widgets.
179189-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.
180190listViewWithKey :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
181−listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
191+listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
182192
183193listViewWithKey' :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
184−listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild
194+listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
185195
186196-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
187197selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
@@ -195,14 +205,14 @@ selectViewListWithKey selection vals mkChild = do
195205 selected <- getDemuxed selectionDemux k
196206 selectSelf <- mkChild k v selected
197207 return $ fmap ((,) k) selectSelf
198− liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
208+ return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
199209
200210selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
201211 => Dynamic t k -- ^ Current selection key
202212 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
203213 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected
204214 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
205−selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewListWithKey selection vals mkChild
215+selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
206216
207217{-
208218{-# INLINABLE elWith #-}
@@ -230,34 +240,26 @@ emptyElWith' elementTag cfg = do
230240 wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
231241-}
232242
233−dynamicAttributesToModifyAttributes :: PostBuild t m => Dynamic t (Map Text Text) -> m (Event t (Map AttributeName (Maybe Text)))
234−dynamicAttributesToModifyAttributes d = do
235− postBuild <- getPostBuild
236− let modificationsNeeded = flip pushAlways (align postBuild $ updated d) $ \case
237− This () -> fmap (fmap Just) $ sample $ current d
238− These () new -> return $ fmap Just new
239− That new -> do
240− old <- sample $ current d
241− return $ diffMap old new
242− return $ Map.fromList . fmap (\(k, v) -> ((Nothing, k), v)) . Map.toList <$> modificationsNeeded
243−
244−{-# INLINABLE elDynAttrNS' #-}
245−elDynAttrNS' :: forall t m a. (DomBuilder t m, PostBuild t m) => Maybe Text -> Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
246−elDynAttrNS' mns elementTag attrs child = do
247− modifyAttrs <- dynamicAttributesToModifyAttributes attrs
248− let cfg = def
249− & elementConfig_namespace .~ mns
250− & modifyAttributes .~ modifyAttrs
251− element elementTag cfg child
252−
253−{-# INLINABLE elDynAttr' #-}
254−elDynAttr' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
255−elDynAttr' = elDynAttrNS' Nothing
243+{-# INLINABLE el #-}
244+el :: forall t m a. DomBuilder t m => Text -> m a -> m a
245+el elementTag child = snd <$> el' elementTag child
256246
257247{-# INLINABLE elAttr #-}
258248elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a
259249elAttr elementTag attrs child = snd <$> elAttr' elementTag attrs child
260250
251+{-# INLINABLE elClass #-}
252+elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a
253+elClass elementTag c child = snd <$> elClass' elementTag c child
254+
255+{-# INLINABLE elDynAttr #-}
256+elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
257+elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child
258+
259+{-# INLINABLE elDynClass #-}
260+elDynClass :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m a
261+elDynClass elementTag c child = snd <$> elDynClass' elementTag c child
262+
261263{-# INLINABLE el' #-}
262264el' :: forall t m a. DomBuilder t m => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
263265el' elementTag = element elementTag def
@@ -265,18 +267,39 @@ el' elementTag = element elementTag def
265267{-# INLINABLE elAttr' #-}
266268elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
267269elAttr' elementTag attrs = element elementTag $ def
268− & initialAttributes .~ (Map.fromList $ fmap (\(k, v) -> ((Nothing, k), v)) $ Map.toList $ attrs)
270+ & initialAttributes .~ Map.mapKeys (\k -> (Nothing, k)) attrs
269271
270−{-# INLINABLE elDynAttr #-}
271−elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
272−elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child
272+{-# INLINABLE elClass' #-}
273+elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
274+elClass' elementTag c = elAttr' elementTag ("class" =: c)
273275
274−{-# INLINABLE el #-}
275−el :: forall t m a. DomBuilder t m => Text -> m a -> m a
276−el elementTag child = snd <$> el' elementTag child
276+{-# INLINABLE elDynAttr' #-}
277+elDynAttr' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
278+elDynAttr' = elDynAttrNS' Nothing
277279
278−elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a
279−elClass elementTag c child = fmap snd $ element elementTag (def & initialAttributes .~ (Nothing, "class") =: c) child
280+{-# INLINABLE elDynClass' #-}
281+elDynClass' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
282+elDynClass' elementTag c = elDynAttr' elementTag (fmap ("class" =:) c)
283+
284+{-# INLINABLE elDynAttrNS' #-}
285+elDynAttrNS' :: forall t m a. (DomBuilder t m, PostBuild t m) => Maybe Text -> Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
286+elDynAttrNS' mns elementTag attrs child = do
287+ modifyAttrs <- dynamicAttributesToModifyAttributes attrs
288+ let cfg = def
289+ & elementConfig_namespace .~ mns
290+ & modifyAttributes .~ modifyAttrs
291+ element elementTag cfg child
292+
293+dynamicAttributesToModifyAttributes :: PostBuild t m => Dynamic t (Map Text Text) -> m (Event t (Map AttributeName (Maybe Text)))
294+dynamicAttributesToModifyAttributes d = do
295+ postBuild <- getPostBuild
296+ let modificationsNeeded = flip pushAlways (align postBuild $ updated d) $ \case
297+ This () -> fmap (fmap Just) $ sample $ current d
298+ These () new -> return $ fmap Just new
299+ That new -> do
300+ old <- sample $ current d
301+ return $ diffMap old new
302+ return $ Map.fromList . fmap (\(k, v) -> ((Nothing, k), v)) . Map.toList <$> modificationsNeeded
280303
281304--------------------------------------------------------------------------------
282305-- Copied and pasted from Reflex.Widget.Class
@@ -289,7 +312,7 @@ list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
289312
290313-- | Create a dynamically-changing set of widgets from a Dynamic list.
291314simpleList :: (DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
292−simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs
315+simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs
293316
294317{-
295318schedulePostBuild x = performEvent_ . (x <$) =<< getPostBuild
@@ -325,17 +348,17 @@ newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)
325348
326349workflow :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
327350workflow w0 = do
328− rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ fmap snd $ current eResult
329− mapDyn fst eResult
351+ rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
352+ return $ fmap fst eResult
330353
331354workflowView :: forall t m a. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)
332355workflowView w0 = do
333− rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
334− eReplace <- liftM switch $ hold never $ fmap snd eResult
356+ rec eResult <- dyn . fmap unWorkflow =<< holdDyn w0 eReplace
357+ eReplace <- fmap switch $ hold never $ fmap snd eResult
335358 return $ fmap fst eResult
336359
337360mapWorkflow :: (DomBuilder t m) => (a -> b) -> Workflow t m a -> Workflow t m b
338−mapWorkflow f (Workflow x) = Workflow (fmap (\(v,e) -> (f v, fmap (mapWorkflow f) e)) x)
361+mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
339362
340363divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
341364divClass = elClass "div"
@@ -343,7 +366,7 @@ divClass = elClass "div"
343366dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a
344367dtdd h w = do
345368 el "dt" $ text h
346− el "dd" $ w
369+ el "dd" w
347370
348371blank :: forall m. Monad m => m ()
349372blank = return ()
@@ -376,9 +399,9 @@ tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuil
376399tabDisplay ulClass activeClass tabItems = do
377400 let t0 = listToMaybe $ Map.keys tabItems
378401 rec currentTab :: Demux t (Maybe k) <- elAttr "ul" ("class" =: ulClass) $ do
379− tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< getDemuxed currentTab (Just k)) tabItems
402+ tabClicksList :: [Event t k] <- Map.elems <$> imapM (\k (s,_) -> headerBarLink s k =<< getDemuxed currentTab (Just k)) tabItems
380403 let eTabClicks :: Event t k = leftmost tabClicksList
381− liftM demux $ holdDyn t0 $ fmap Just eTabClicks
404+ fmap demux $ holdDyn t0 $ fmap Just eTabClicks
382405 el "div" $ do
383406 iforM_ tabItems $ \k (_, w) -> do
384407 isSelected <- getDemuxed currentTab $ Just k
@@ -388,7 +411,7 @@ tabDisplay ulClass activeClass tabItems = do
388411 where
389412 headerBarLink :: Text -> k -> Dynamic t Bool -> m (Event t k)
390413 headerBarLink x k isSelected = do
391− attrs <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) isSelected
414+ let attrs = fmap (\b -> if b then Map.singleton "class" activeClass else Map.empty) isSelected
392415 elDynAttr "li" attrs $ do
393416 a <- link x
394417 return $ fmap (const k) (_link_clicked a)