bf1ce6a · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Implement new Patch*MapWithMove-based primitive for MonadAdjust

commitbf1ce6af3a09a40ea7e9fa9ea9a8e78f077a61a9 authorRyan Trinkle <ryan.trinkle@gmail.com> dateThu 9 Feb 2017, 21:33 (10 years ago) parent9626d64

6 files changed+176−37

compare with develop

unifiedsplit

examples/sortableList.hs+55 reflex-dom.cabal+27 src/Foreign/JavaScript/TH.hs+2−1 src/Reflex/Dom/Builder/Immediate.hs+83−23 src/Reflex/Dom/Builder/InputDisabled.hs+2−1 src/Reflex/Dom/Builder/Static.hs+7−12

examples/sortableList.hsnew file+55

@@ -0,0 +1,55 @@

1+{-# LANGUAGE GADTs #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE RecursiveDo #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+import Control.Lens

7+import Control.Monad.Identity

8+import Data.Dependent.Map (DMap)

9+import Data.Functor.Constant

10+import Data.Functor.Misc

11+import Data.Map (Map)

12+import qualified Data.Map as Map

13+import Data.Ord

14+import qualified Data.Text as T

15+import Reflex.Dom

16+import System.Random

17+

18+main :: IO ()

19+main = mainWidget $ do

20+ let f k v = el "li" $ do

21+ text $ T.pack $ show (k, v)

22+ inputElement def

23+ return ()

24+ let numKeys = 1000 :: Int

25+ keys = take numKeys [0 :: Int ..]

26+ values :: [(Int, Int, Int)]

27+ values = zip3 (randoms (mkStdGen 0)) (randoms (mkStdGen 1)) (randoms (mkStdGen 2))

28+ testMap = Map.fromList $ zip keys values

29+ resort <- leftmost <$> sequence

30+ [ fmap (comparing (view _1) <$) $ button "1 ASC"

31+ , fmap (flip (comparing (view _1)) <$) $ button "1 DESC"

32+ , fmap (comparing (view _2) <$) $ button "2 ASC"

33+ , fmap (flip (comparing (view _2)) <$) $ button "2 DESC"

34+ , fmap (comparing (view _3) <$) $ button "3 ASC"

35+ , fmap (flip (comparing (view _3)) <$) $ button "3 DESC"

36+ ]

37+ simpleSortableList f testMap resort

38+ return ()

39+

40+mapMapWithAdjust :: forall t m k v v'. (MonadAdjust t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMap k v) -> m (Map k v', Event t (PatchMap k v'))

41+mapMapWithAdjust f m0 m' = do

42+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjust (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWith Identity <$> m')

43+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapToPatchMapWith (\(Constant v') -> v') <$> out')

44+

45+mapMapWithAdjustWithMove :: forall t m k v v'. (MonadAdjust t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v'))

46+mapMapWithAdjustWithMove f m0 m' = do

47+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')

48+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')

49+

50+simpleSortableList :: (MonadHold t m, MonadFix m, MonadAdjust t m, Ord k) => (k -> v -> m ()) -> Map k v -> Event t (v -> v -> Ordering) -> m ()

51+simpleSortableList f m0 resortFunc = do

52+ rec let resortPatch = attachWith (flip patchThatSortsMapWith) (currentIncremental m) resortFunc

53+ m <- holdIncremental m0 resortPatch

54+ _ <- mapMapWithAdjustWithMove f m0 resortPatch

55+ return ()

reflex-dom.cabal+27

@@ -30,6 +30,11 @@ flag expose-all-unfoldings

3030 default: False

3131 manual: True

3232

33+flag build-examples

34+ description: Build the executables in ./examples

35+ default: False

36+ manual: True

37+

3338library

3439 hs-source-dirs: src

3540 build-depends:

@@ -128,6 +133,28 @@ test-suite hlint

128133 main-is: hlint.hs

129134 type: exitcode-stdio-1.0

130135

136+executable sortableList

137+ build-depends: base

138+ , containers

139+ , dependent-map

140+ , lens

141+ , mtl

142+ , random

143+ , reflex

144+ , reflex-dom

145+ , text

146+ , transformers

147+ hs-source-dirs: examples

148+ main-is: sortableList.hs

149+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

150+ ghc-prof-options: -fprof-auto

151+ if !flag(build-examples)

152+ buildable: False

153+ if flag(expose-all-unfoldings)

154+ ghc-options: -fexpose-all-unfoldings

155+ if flag(use-reflex-optimizer)

156+ ghc-options: -fplugin=Reflex.Optimizer

157+

131158source-repository head

132159 type: git

133160 location: https://github.com/reflex-frp/reflex-dom

src/Foreign/JavaScript/TH.hs+2−1

@@ -127,7 +127,8 @@ instance PrimMonad m => PrimMonad (WithWebView x m) where

127127

128128instance MonadAdjust t m => MonadAdjust t (WithWebView x m) where

129129 runWithReplace a0 a' = WithWebView $ runWithReplace (coerce a0) (coerceEvent a')

130− sequenceDMapWithAdjust dm0 dm' = WithWebView $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')

130+ traverseDMapWithKeyWithAdjust f dm0 dm' = WithWebView $ traverseDMapWithKeyWithAdjust (\k v -> unWithWebView $ f k v) (coerce dm0) (coerceEvent dm')

131+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = WithWebView $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unWithWebView $ f k v) (coerce dm0) (coerceEvent dm')

131132

132133instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where

133134 {-# INLINABLE newEventWithTrigger #-}

src/Reflex/Dom/Builder/Immediate.hs+83−23

@@ -40,13 +40,13 @@ import Data.Default

4040import Data.Dependent.Map (DMap)

4141import qualified Data.Dependent.Map as DMap

4242import Data.Dependent.Sum

43+import Data.Functor.Compose

44+import Data.Functor.Constant

4345import Data.Functor.Misc

4446import Data.IORef

45−import Data.Map (Map)

4647import qualified Data.Map as Map

4748import Data.Maybe

4849import Data.Monoid

49−import Data.Some (Some)

5050import qualified Data.Some as Some

5151import Data.Text (Text)

5252import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)

@@ -65,8 +65,8 @@ import qualified GHCJS.DOM.Touch as Touch

6565import qualified GHCJS.DOM.TouchEvent as TouchEvent

6666import qualified GHCJS.DOM.TouchList as TouchList

6767#endif

68−import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, removeChild,

69− setNodeValue, toNode)

68+import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, getNextSibling,

69+ removeChild, setNodeValue, toNode)

7070import qualified GHCJS.DOM.Node as DOM

7171import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,

7272 WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,

@@ -165,6 +165,12 @@ deleteUpTo s e = do

165165 Nothing -> return () --TODO: Is this the right behavior?

166166 Just currentParent -> deleteUpToGivenParent currentParent s e

167167

168+{-# INLINABLE collectUpTo #-}

169+collectUpTo :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment

170+collectUpTo s e = do

171+ Just currentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

172+ collectUpToGivenParent currentParent s e

173+

168174{-# INLINABLE deleteUpToGivenParent #-}

169175deleteUpToGivenParent :: (MonadIO m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()

170176deleteUpToGivenParent currentParent s e = do

@@ -173,6 +179,18 @@ deleteUpToGivenParent currentParent s e = do

173179 _ <- removeChild currentParent $ Just x

174180 when (toNode s /= toNode x) loop

175181

182+{-# INLINABLE collectUpToGivenParent #-}

183+collectUpToGivenParent :: (MonadIO m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m DOM.DocumentFragment

184+collectUpToGivenParent currentParent s e = do

185+ Just doc <- getOwnerDocument currentParent

186+ Just df <- createDocumentFragment doc

187+ let loop this = when (toNode e /= this) $ do

188+ Just next <- getNextSibling this -- This can't be Nothing because we should hit 'e' first

189+ _ <- appendChild df $ Just this -- This will also remove 'this' from its current parent

190+ loop next

191+ loop $ toNode s

192+ return df

193+

176194type SupportsImmediateDomBuilder t m = (Reflex t, MonadIO m, MonadIO (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO, MonadAdjust t m)

177195

178196newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))

@@ -416,36 +434,78 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m,

416434 insertBefore df after

417435 return result

418436 return (result0, result')

419− sequenceDMapWithAdjust (dm0 :: DMap k (ImmediateDomBuilderT t m)) dm' = do

437+ traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

420438 initialEnv <- ImmediateDomBuilderT ask

421− let drawChildInitial :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)

422− drawChildInitial child = runImmediateDomBuilderT ((,,) <$> pure (error "sequenceDMapWithAdjust{ImmediateDomBuilderT}: drawChildInitial: DocumentFragment evaluated") <*> textNodeInternal ("" :: Text) <*> child) initialEnv --TODO: Don't return a DocumentFragment at all here; this will require that sequenceDMapWithAdjust accept differently-typed values for the constant and Event arguments.

423− drawChildUpdate :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)

439+ let drawChildUpdate :: forall a. ImmediateDomBuilderT t m (v' a) -> m (Compose ((,,) DOM.DocumentFragment DOM.Text) v' a)

424440 drawChildUpdate child = do

425441 Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

426− runImmediateDomBuilderT ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child) $ initialEnv

442+ runImmediateDomBuilderT (Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv

427443 { _immediateDomBuilderEnv_parent = toNode df

428444 }

429− updateChildren = ffor dm' $ \(PatchDMap p) -> PatchDMap $

430− mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap drawChildUpdate mv)) p

431− (children0, children') <- lift $ sequenceDMapWithAdjust (mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> drawChildInitial v) dm0) (updateChildren :: Event t (PatchDMap (WrapArg ((,,) DOM.DocumentFragment DOM.Text) k) m)) --TODO: Update stuff

432− let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, _, v)) -> k :=> Identity v) children0

433− placeholders0 = dmapToMap $ mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, ph, _)) -> Const2 (Some.This k) :=> Identity ph) children0

434− result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

435− mapKeyValuePairsMonotonic (\(WrapArg k :=> v) -> k :=> fmap (\(_, _, r) -> r) v) p

436− placeholders' = ffor children' $ \(PatchDMap p) -> PatchMap $

437− dmapToMap $ mapKeyValuePairsMonotonic (\(WrapArg k :=> v) -> Const2 (Some.This k) :=> Identity (fmap ((\(_, ph, _) -> ph) . runIdentity) (getComposeMaybe v))) p

438− placeholders :: Behavior t (Map (Some k) DOM.Text) <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'

445+ (children0, children') <- lift $ traverseDMapWithKeyWithAdjust (\k v -> drawChildUpdate $ f k v) dm0 dm'

446+ let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0

447+ placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0

448+ result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, r)) -> r

449+ placeholders' = fforCheap children' $ weakenPatchDMapWith $ \(Compose (_, ph, _)) -> ph

450+ placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'

451+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0

439452 lastPlaceholder <- textNodeInternal ("" :: Text)

440453 performEvent_ $ flip push children' $ \(PatchDMap p) -> do

441454 phs <- sample placeholders

442455 if DMap.null p then return Nothing else return $ Just $ do

443− let f :: DSum (WrapArg ((,,) DOM.DocumentFragment DOM.Text) k) (ComposeMaybe Identity) -> Performable m ()

444− f (WrapArg k :=> ComposeMaybe mv) = do

456+ let g :: DSum k (ComposeMaybe (Compose ((,,) DOM.DocumentFragment DOM.Text) v')) -> Performable m ()

457+ g (k :=> ComposeMaybe mv) = do

445458 let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs

446459 forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

447− forM_ mv $ \(Identity (df, _, _)) -> df `insertBefore` nextPlaceholder

448− mapM_ f $ DMap.toList p

460+ forM_ mv $ \(Compose (df, _, _)) -> df `insertBefore` nextPlaceholder

461+ mapM_ g $ DMap.toList p

462+ return (result0, result')

463+ traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

464+ initialEnv <- ImmediateDomBuilderT ask

465+ let drawChildUpdate :: forall a. ImmediateDomBuilderT t m (v' a) -> m (Compose ((,,) DOM.DocumentFragment DOM.Text) v' a)

466+ drawChildUpdate child = do

467+ Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

468+ runImmediateDomBuilderT (Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv

469+ { _immediateDomBuilderEnv_parent = toNode df

470+ }

471+ (children0, children') <- lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> drawChildUpdate $ f k v) dm0 dm'

472+ let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0

473+ placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0

474+ result' = ffor children' $ mapPatchDMapWithMove $ \(Compose (_, _, r)) -> r

475+ placeholders' = fforCheap children' $ weakenPatchDMapWithMoveWith $ \(Compose (_, ph, _)) -> ph

476+ placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'

477+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0

478+ lastPlaceholder <- textNodeInternal ("" :: Text)

479+ performEvent_ $ flip push children' $ \p_ -> do

480+ let p = unPatchDMapWithMove p_

481+ phsBefore <- sample placeholders

482+ if DMap.null p then return Nothing else return $ Just $ do

483+ let collectIfMoved :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> Performable m (Constant (Maybe DOM.DocumentFragment) a)

484+ collectIfMoved k e = do

485+ Just thisPlaceholder <- return $ Map.lookup (Some.This k) phsBefore

486+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore

487+ case dmapEditMoved e of

488+ False -> do

489+ thisPlaceholder `deleteUpTo` nextPlaceholder

490+ return $ Constant Nothing

491+ True -> do

492+ Constant . Just <$> thisPlaceholder `collectUpTo` nextPlaceholder

493+ collected <- DMap.traverseWithKey collectIfMoved p

494+ let phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _)) -> ph) p_) phsBefore --TODO: Don't recompute this

495+ let placeFragment :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> Performable m (Constant () a)

496+ placeFragment k e = do

497+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter

498+ case e of

499+ DMapEdit_Insert _ (Compose (df, _, _)) -> do

500+ df `insertBefore` nextPlaceholder

501+ DMapEdit_Delete _ -> do

502+ return ()

503+ DMapEdit_Move _ fromKey -> do

504+ Just (Constant (Just df)) <- return $ DMap.lookup fromKey collected

505+ df `insertBefore` nextPlaceholder

506+ return $ Constant ()

507+ mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time

508+ return ()

449509 return (result0, result')

450510

451511mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

src/Reflex/Dom/Builder/InputDisabled.hs+2−1

@@ -68,7 +68,8 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (InputDisabl

6868

6969instance MonadAdjust t m => MonadAdjust t (InputDisabledT m) where

7070 runWithReplace a0 a' = InputDisabledT $ runWithReplace (coerce a0) (coerceEvent a')

71− sequenceDMapWithAdjust dm0 dm' = InputDisabledT $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')

71+ traverseDMapWithKeyWithAdjust f dm0 dm' = InputDisabledT $ traverseDMapWithKeyWithAdjust (\k v -> runInputDisabledT $ f k v) (coerce dm0) (coerceEvent dm')

72+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = InputDisabledT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runInputDisabledT $ f k v) (coerce dm0) (coerceEvent dm')

7273

7374instance DomBuilder t m => DomBuilder t (InputDisabledT m) where

7475 type DomBuilderSpace (InputDisabledT m) = DomBuilderSpace m

src/Reflex/Dom/Builder/Static.hs+7−12

@@ -31,8 +31,8 @@ import Data.Default

3131import Data.Dependent.Map (DMap)

3232import qualified Data.Dependent.Map as DMap

3333import Data.Dependent.Sum (DSum (..))

34+import Data.Functor.Compose

3435import Data.Functor.Constant

35−import Data.Functor.Misc

3636import qualified Data.Map as Map

3737import Data.Monoid

3838import qualified Data.Set as Set

@@ -150,20 +150,15 @@ instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomB

150150 o <- hold (snd result0) $ fmapCheap snd result'

151151 StaticDomBuilderT $ modify $ (:) $ join o

152152 return (fst result0, fmapCheap fst result')

153− sequenceDMapWithAdjust (dm0 :: DMap k (StaticDomBuilderT t m)) dm' = do

153+ traverseDMapWithKeyWithAdjust f (dm0 :: DMap k v) dm' = do

154154 e <- StaticDomBuilderT ask

155− let loweredDm0 = mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> fmap swap (runStaticDomBuilderT v e)) dm0

156− loweredDm' = ffor dm' $ \(PatchDMap p) -> PatchDMap $

157− mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap (fmap swap . flip runStaticDomBuilderT e) mv)) p

158− (children0, children') <- lift $ sequenceDMapWithAdjust loweredDm0 loweredDm'

159− let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0

160− result' = ffor children' $ \(PatchDMap p) -> PatchDMap $

161− mapKeyValuePairsMonotonic (\(WrapArg k :=> mv) -> k :=> fmap snd mv) p

155+ (children0, children') <- lift $ traverseDMapWithKeyWithAdjust (\k v -> fmap (Compose . swap) (runStaticDomBuilderT (f k v) e)) dm0 dm'

156+ let result0 = DMap.map (snd . getCompose) children0

157+ result' = ffor children' $ mapPatchDMap $ snd . getCompose

162158 outputs0 :: DMap k (Constant (Behavior t Builder))

163− outputs0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (o, _)) -> k :=> Constant o) children0

159+ outputs0 = DMap.map (Constant . fst . getCompose) children0

164160 outputs' :: Event t (PatchDMap k (Constant (Behavior t Builder)))

165− outputs' = ffor children' $ \(PatchDMap p) -> PatchDMap $

166− mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Constant . fst . runIdentity) mv)) p

161+ outputs' = ffor children' $ mapPatchDMap $ Constant . fst . getCompose

167162 outputs <- holdIncremental outputs0 outputs'

168163 StaticDomBuilderT $ modify $ (:) $ pull $ do

169164 os <- sample $ currentIncremental outputs