@@ -1,55 +1,88 @@
1+{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE RecursiveDo #-}
6{-# LANGUAGE RecursiveDo #-}
5{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
6import Control.Lens
8import Control.Lens
7import Control.Monad.Identity
9import Control.Monad.Identity
10+import Control.Monad.IO.Class
8import Data.Dependent.Map (DMap)
11import Data.Dependent.Map (DMap)
9import Data.Functor.Constant
12import Data.Functor.Constant
10import Data.Functor.Misc
13import Data.Functor.Misc
11import Data.Map (Map)
15import Data.Map (Map)
12import qualified Data.Map as Map
16import qualified Data.Map as Map
13import Data.Ord
18import Data.Ord
14import qualified Data.Text as T
19import qualified Data.Text as T
20+import Data.Time.Clock
15import Reflex.Dom
21import Reflex.Dom
16import System.Random
22import System.Random
18main :: IO ()
24main :: IO ()
19main = mainWidget $ do
25main = mainWidget $ do
20− let f k v = el "li" $ do
26+ let f k (a, b, c) = el "tr" $ do
21− text $ T.pack $ show (k, v)
27+ mapM_ (el "td" . text . T.pack . show) [k, a, b, c]
22− inputElement def
28+ _ <- el "td" $ inputElement def
24 let numKeys = 1000 :: Int
30 let numKeys = 1000 :: Int
25 keys = take numKeys [0 :: Int ..]
31 keys = take numKeys [0 :: Int ..]
26 values :: [(Int, Int, Int)]
32 values :: [(Int, Int, Int)]
27 values = zip3 (randoms (mkStdGen 0)) (randoms (mkStdGen 1)) (randoms (mkStdGen 2))
33 values = zip3 (randoms (mkStdGen 0)) (randoms (mkStdGen 1)) (randoms (mkStdGen 2))
28 testMap = Map.fromList $ zip keys values
34 testMap = Map.fromList $ zip keys values
29− resort <- leftmost <$> sequence
35+ resortButtons = el "div" $ leftmost <$> sequence
30− [ (comparing (view _1) <$) <$> button "1 ASC"
36+ [ (comparing (view _1) <$) <$> button "1 ASC"
31− , (flip (comparing (view _1)) <$) <$> button "1 DESC"
37+ , (flip (comparing (view _1)) <$) <$> button "1 DESC"
32− , (comparing (view _2) <$) <$> button "2 ASC"
38+ , (comparing (view _2) <$) <$> button "2 ASC"
33− , (flip (comparing (view _2)) <$) <$> button "2 DESC"
39+ , (flip (comparing (view _2)) <$) <$> button "2 DESC"
34− , (comparing (view _3) <$) <$> button "3 ASC"
40+ , (comparing (view _3) <$) <$> button "3 ASC"
35− , (flip (comparing (view _3)) <$) <$> button "3 DESC"
41+ , (flip (comparing (view _3)) <$) <$> button "3 DESC"
43+ el "h1" $ text "Improved list sorting"
44+ el "p" $ text $ "This app shows a table of " <> T.pack (show numKeys) <> " items, and allows you to re-sort by columns a, b, and c, which are full of pseudorandom numbers."
45+ el "h3" $ text "Re-sort the list the OLD way (by redrawing everything)"
46+ resortSlow <- resortButtons
47+ displayRedrawTime resortSlow
48+ el "h3" $ text "Re-sort the list the NEW way (by reordering existing elements)"
49+ resort <- resortButtons
50+ displayRedrawTime resort
58+ el "th" $ text "Stateful Element (textbox)"
37− simpleSortableList f testMap resort
59+ simpleSortableList f testMap resort resortSlow
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'))
62+displayRedrawTime :: (DomBuilder t m, MonadHold t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => Event t a -> m ()
41−mapMapWithAdjust f m0 m' = do
63+displayRedrawTime e = do
42− (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjust (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWith Identity <$> m')
64+ et1 <- performEvent $ liftIO getCurrentTime <$ e
43− return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapToPatchMapWith (\(Constant v') -> v') <$> out')
65+ et1' <- delay 0 et1
66+ diff <- performEvent $ ffor et1' $ \t1 -> do
67+ t2 <- liftIO getCurrentTime
68+ return $ t2 `diffUTCTime` t1
70+ dynText =<< holdDyn "not yet run" (T.pack . show <$> diff)
45mapMapWithAdjustWithMove :: 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'))
72mapMapWithAdjustWithMove :: 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'))
46mapMapWithAdjustWithMove f m0 m' = do
73mapMapWithAdjustWithMove 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')
74 (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')
75 return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
50−simpleSortableList :: (MonadHold t m, MonadFix m, MonadAdjust t m, Ord k) => (k -> v -> m ()) -> Map k v -> Event t (v -> v -> Ordering) -> m ()
77+simpleSortableList :: forall t m k v. (MonadHold t m, MonadFix m, MonadAdjust t m, Ord k) => (k -> v -> m ()) -> Map k v -> Event t (v -> v -> Ordering) -> Event t (v -> v -> Ordering) -> m ()
51−simpleSortableList f m0 resortFunc = do
78+simpleSortableList f m0 resortFunc resortSlowFunc = do
52 rec let resortPatch = attachWith (flip patchThatSortsMapWith) (currentIncremental m) resortFunc
79 rec let resortPatch = attachWith (flip patchThatSortsMapWith) (currentIncremental m) resortFunc
80+ redrawPatch :: Map k v -> (v -> v -> Ordering) -> PatchMapWithMove k v
81+ redrawPatch d cmp = unsafePatchMapWithMove $ fmap (MapEdit_Insert False) $ Map.fromList $ zip (Map.keys d) (sortBy cmp $ Map.elems d)
82+ resortPatchSlow = attachWith redrawPatch (currentIncremental m) resortSlowFunc
53 m <- holdIncremental m0 resortPatch
83 m <- holdIncremental m0 resortPatch
54− _ <- mapMapWithAdjustWithMove f m0 resortPatch
84+ _ <- mapMapWithAdjustWithMove f m0 $ leftmost