@@ -1,55 +1,88 @@
1+{-# LANGUAGE FlexibleContexts #-}
12{-# LANGUAGE GADTs #-}
23{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE OverloadedStrings #-}
35{-# LANGUAGE RankNTypes #-}
46{-# LANGUAGE RecursiveDo #-}
57{-# LANGUAGE ScopedTypeVariables #-}
68import Control.Lens
79import Control.Monad.Identity
10+import Control.Monad.IO.Class
811import Data.Dependent.Map (DMap)
912import Data.Functor.Constant
1013import Data.Functor.Misc
14+import Data.List
1115import Data.Map (Map)
1216import qualified Data.Map as Map
17+import Data.Monoid
1318import Data.Ord
1419import qualified Data.Text as T
20+import Data.Time.Clock
1521import Reflex.Dom
1622import System.Random
1723
1824main :: IO ()
1925main = mainWidget $ do
20− let f k v = el "li" $ do
21− text $ T.pack $ show (k, v)
22− inputElement def
26+ let f k (a, b, c) = el "tr" $ do
27+ mapM_ (el "td" . text . T.pack . show) [k, a, b, c]
28+ _ <- el "td" $ inputElement def
2329 return ()
2430 let numKeys = 1000 :: Int
2531 keys = take numKeys [0 :: Int ..]
2632 values :: [(Int, Int, Int)]
2733 values = zip3 (randoms (mkStdGen 0)) (randoms (mkStdGen 1)) (randoms (mkStdGen 2))
2834 testMap = Map.fromList $ zip keys values
29− resort <- leftmost <$> sequence
30− [ (comparing (view _1) <$) <$> button "1 ASC"
31− , (flip (comparing (view _1)) <$) <$> button "1 DESC"
32− , (comparing (view _2) <$) <$> button "2 ASC"
33− , (flip (comparing (view _2)) <$) <$> button "2 DESC"
34− , (comparing (view _3) <$) <$> button "3 ASC"
35− , (flip (comparing (view _3)) <$) <$> button "3 DESC"
36− ]
37− simpleSortableList f testMap resort
35+ resortButtons = el "div" $ leftmost <$> sequence
36+ [ (comparing (view _1) <$) <$> button "1 ASC"
37+ , (flip (comparing (view _1)) <$) <$> button "1 DESC"
38+ , (comparing (view _2) <$) <$> button "2 ASC"
39+ , (flip (comparing (view _2)) <$) <$> button "2 DESC"
40+ , (comparing (view _3) <$) <$> button "3 ASC"
41+ , (flip (comparing (view _3)) <$) <$> button "3 DESC"
42+ ]
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
51+ el "hr" blank
52+ el "table" $ do
53+ el "tr" $ do
54+ el "th" $ text "Key"
55+ el "th" $ text "A"
56+ el "th" $ text "B"
57+ el "th" $ text "C"
58+ el "th" $ text "Stateful Element (textbox)"
59+ simpleSortableList f testMap resort resortSlow
3860 return ()
3961
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')
62+displayRedrawTime :: (DomBuilder t m, MonadHold t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => Event t a -> m ()
63+displayRedrawTime e = do
64+ et1 <- performEvent $ liftIO getCurrentTime <$ e
65+ et1' <- delay 0 et1
66+ diff <- performEvent $ ffor et1' $ \t1 -> do
67+ t2 <- liftIO getCurrentTime
68+ return $ t2 `diffUTCTime` t1
69+ text "Time: "
70+ dynText =<< holdDyn "not yet run" (T.pack . show <$> diff)
4471
4572mapMapWithAdjustWithMove :: 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'))
4673mapMapWithAdjustWithMove f m0 m' = do
4774 (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
4875 return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
4976
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
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 ()
78+simpleSortableList f m0 resortFunc resortSlowFunc = do
5279 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
5383 m <- holdIncremental m0 resortPatch
54− _ <- mapMapWithAdjustWithMove f m0 resortPatch
84+ _ <- mapMapWithAdjustWithMove f m0 $ leftmost
85+ [ resortPatch
86+ , resortPatchSlow
87+ ]
5588 return ()