Make miso todo-mvc use Miso.Lens.

Author: dmjio

flake.lock

@@ -42,7 +42,7 @@ executable app
   main-is:
     Main.hs
   build-depends:
-    base, miso, mtl
+    base, miso, mtl, containers
   default-language:
     GHC2021
   default-extensions:

miso-todomvc.cabal

@@ -2,8 +2,9 @@
 {-# LANGUAGE CPP                #-}
 {-# LANGUAGE LambdaCase         #-}
 {-# LANGUAGE DeriveGeneric      #-}
-{-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE DeriveAnyClass     #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE DerivingStrategies #-}
 -----------------------------------------------------------------------------
@@ -17,61 +18,60 @@
 ----------------------------------------------------------------------------
 module Main where
 ----------------------------------------------------------------------------
-import           Control.Monad.State
+import           Control.Category ((.))
+import qualified Data.IntMap as IM
+import           Data.IntMap (IntMap)
 import           Data.Bool
 import           GHC.Generics
+import           Prelude hiding ((.))
 ----------------------------------------------------------------------------
-import           Miso
+import           Miso hiding (at)
 import           Miso.Html
-import           Miso.JSON
+import           Miso.Lens
+import           Miso.Lens.TH
 import           Miso.Html.Property hiding (label_)
 import qualified Miso.String as S
 import qualified Miso.CSS as CSS
 ----------------------------------------------------------------------------
 default (MisoString)
 ----------------------------------------------------------------------------
-#ifdef WASM
-foreign export javascript "hs_start" main :: IO ()
-#endif
-----------------------------------------------------------------------------
 data Model
   = Model
-  { entries :: [Entry]
-  , field :: MisoString
-  , uid :: Int
-  , visibility :: MisoString
-  , step :: Bool
+  { _entries :: IntMap Entry
+  , _field :: MisoString
+  , _uid :: Int
+  , _visibility :: MisoString
+  , _step :: Bool
   } deriving stock (Show, Generic, Eq)
-    deriving anyclass (FromJSON, ToJSON)
 ----------------------------------------------------------------------------
 data Entry
   = Entry
-  { description :: MisoString
-  , completed :: Bool
-  , editing :: Bool
-  , eid :: Int
-  , focussed :: Bool
+  { _description :: MisoString
+  , _completed :: Bool
+  , _editing :: Bool
+  , _focussed :: Bool
   } deriving stock (Show, Generic, Eq)
-    deriving anyclass (FromJSON, ToJSON)
+----------------------------------------------------------------------------
+$(makeLenses ''Entry)
+$(makeLenses ''Model)
 ----------------------------------------------------------------------------
 emptyModel :: Model
 emptyModel
   = Model
-  { entries = []
-  , visibility = "All"
-  , field = mempty
-  , uid = 0
-  , step = False
+  { _entries = mempty
+  , _visibility = "All"
+  , _field = mempty
+  , _uid = 0
+  , _step = False
   }
 ----------------------------------------------------------------------------
-newEntry :: MisoString -> Int -> Entry
-newEntry desc eid
+newEntry :: MisoString -> Entry
+newEntry desc
   = Entry
-  { description = desc
-  , completed = False
-  , editing = False
-  , eid = eid
-  , focussed = False
+  { _description = desc
+  , _completed = False
+  , _editing = False
+  , _focussed = False
   }
 ----------------------------------------------------------------------------
 data Msg
@@ -89,6 +89,12 @@ data Msg
   | FocusOnInput
   deriving (Show)
 ----------------------------------------------------------------------------
+#ifdef WASM
+#ifndef INTERACTIVE
+foreign export javascript "hs_start" main :: IO ()
+#endif
+#endif
+----------------------------------------------------------------------------
 main :: IO ()
 main = startApp (defaultEvents <> keyboardEvents) app
 ----------------------------------------------------------------------------
@@ -111,72 +117,48 @@ updateModel = \case
   FocusOnInput ->
     io_ (focus "input-box")
   CurrentTime time ->
-    io_ $ consoleLog $ S.ms (show time)
+    io_ $ consoleLog (S.ms time)
   Add -> do
-    model@Model{..} <- get
-    put model
-      { uid = uid + 1
-      , field = mempty
-      , entries = entries <> [newEntry field uid | not $ S.null field]
-      }
-  UpdateField str ->
-    modify update
-      where
-        update m = m { field = str }
-  EditingEntry id' isEditing ->
-    modify $ \m ->
-      m { entries =
-            filterMap (entries m) (\t -> eid t == id') $ \t ->
-              t { editing = isEditing
-                , focussed = isEditing
-                }
-        }
-  UpdateEntry id' task ->
-    modify $ \m -> m
-      { entries = filterMap (entries m) ((== id') . eid) $ \t ->
-          t { description = task }
-      }
-  Delete id' ->
-    modify $ \m -> m
-     { entries = filter (\t -> eid t /= id') (entries m)
-     }
+    value <- use field
+    field .= mempty
+    uid += 1
+    nextId <- use uid
+    entries %= IM.insert nextId (newEntry value)
+  UpdateField str -> do
+    field .= str
+  EditingEntry idx isEditing ->
+    entries . at idx %?= (\e ->
+      e & editing .~ isEditing
+        & focussed .~ isEditing)
+  UpdateEntry idx task ->
+    entries . at idx %?= do
+      description .~ task
+  Delete idx ->
+    entries . at idx .= Nothing
   DeleteComplete ->
-    modify $ \m -> m
-      { entries = filter (not . completed) (entries m)
-      }
-  Check id' isCompleted ->
-    modify $ \m -> m
-      { entries =
-          filterMap (entries m) (\t -> eid t == id') $ \t ->
-            t { completed = isCompleted }
-      }
+    entries %= IM.filter (\entry -> not (entry ^. completed))
+  Check idx isCompleted ->
+    entries . at idx %?= do completed .~ isCompleted
   CheckAll isCompleted ->
-    modify $ \m -> m
-      { entries =
-          filterMap (entries m) (const True) $ \t ->
-            t { completed = isCompleted }
-      }
+    entries %= IM.map (\entry -> entry & completed .~ isCompleted)
   ChangeVisibility v ->
-    modify $ \m -> m { visibility = v }
-----------------------------------------------------------------------------
-filterMap :: [a] -> (a -> Bool) -> (a -> a) -> [a]
-filterMap xs p f = [ if p x then f x else x | x <- xs ]
+    visibility .= v
 ----------------------------------------------------------------------------
 viewModel :: Model -> View model Msg
-viewModel m@Model{..} =
+viewModel m =
     div_
         [ class_ "todomvc-wrapper"
         ]
         [ section_
             [class_ "todoapp"]
-            [ viewInput m field
-            , viewEntries visibility entries
-            , viewControls m visibility entries
+            [ viewInput m (m ^. field)
+            , viewEntries (m ^. visibility) (IM.toList (m ^. entries))
+            , viewControls m (m ^. visibility) (IM.toList (m ^. entries))
             ]
         , infoFooter
         ]
 ----------------------------------------------------------------------------
-viewEntries :: MisoString -> [Entry] -> View model Msg
+viewEntries :: MisoString -> [(Int, Entry)] -> View model Msg
 viewEntries visibility entries =
     section_
         [ class_ "main"
@@ -194,40 +176,36 @@ viewEntries visibility entries =
             [for_ "toggle-all"]
             [text $ S.pack "Mark all as complete"]
         , ul_ [class_ "todo-list"] $
-            flip map (filter isVisible entries) $ \t ->
-                viewKeyedEntry t
+            filter isVisible entries <&> viewEntry
         ]
   where
     cssVisibility = bool "visible" "hidden" (null entries)
-    allCompleted = all completed entries
-    isVisible Entry{..} =
+    allCompleted = all _completed (snd <$> entries)
+    isVisible (_, Entry {..}) =
         case visibility of
-            "Completed" -> completed
-            "Active" -> not completed
+            "Completed" -> _completed
+            "Active" -> not _completed
             _ -> True
 ----------------------------------------------------------------------------
-viewKeyedEntry :: Entry -> View model Msg
-viewKeyedEntry = viewEntry
-----------------------------------------------------------------------------
-viewEntry :: Entry -> View model Msg
-viewEntry Entry{..} =
+viewEntry :: (Int, Entry) -> View model Msg
+viewEntry (eid, Entry{..}) =
     li_
         [ class_ $
             S.intercalate " " $
-                ["completed" | completed] <> ["editing" | editing]
+                ["completed" | _completed] <> ["editing" | _editing]
         , key_ eid
         ]
         [ div_
             [class_ "view"]
             [ input_
                 [ class_ "toggle"
                 , type_ "checkbox"
-                , checked_ completed
-                , onClick $ Check eid (not completed)
+                , checked_ _completed
+                , onClick $ Check eid (not _completed)
                 ]
             , label_
                 [onDoubleClick (EditingEntry eid True) ]
-                [text description]
+                [text _description]
             , button_
                 [ class_ "destroy"
                 , onClick $ Delete eid
@@ -236,7 +214,7 @@ viewEntry Entry{..} =
             ]
         , input_
             [ class_ "edit"
-            , value_ description
+            , value_ _description
             , name_ "title"
             , id_ ("todo-" <> S.ms eid)
             , onInput (UpdateEntry eid)
@@ -245,7 +223,7 @@ viewEntry Entry{..} =
             ]
         ]
 ----------------------------------------------------------------------------
-viewControls :: Model -> MisoString -> [Entry] -> View model Msg
+viewControls :: Model -> MisoString -> [(Int,Entry)] -> View model Msg
 viewControls model visibility entries =
     footer_
         [ class_ "footer"
@@ -256,7 +234,7 @@ viewControls model visibility entries =
         , viewControlsClear model entriesCompleted
         ]
   where
-    entriesCompleted = length . filter completed $ entries
+    entriesCompleted = length . filter (_completed . snd) $ entries
     entriesLeft = length entries - entriesCompleted
 ----------------------------------------------------------------------------
 viewControlsCount :: Int -> View model Msg