Refactored update to be more pure

spago.dhall

@@ -24,6 +24,7 @@ to generate this file without the comments in this block.
   , "exceptions"
   , "fetch"
   , "filterable"
+  , "free"
   , "halogen"
   , "maybe"
   , "newtype"

src/UI.purs

@@ -10,15 +10,17 @@ import Aviary.Model ( GalleryError(..)
                     )
 
 import Control.Parallel (parSequence_)
-import Data.Array (index, length, mapMaybe, mapWithIndex, modifyAt)
+import Control.Monad.Free (liftF)
+import Data.Array (index, length, mapWithIndex, modifyAt)
 import Data.Maybe (fromMaybe, maybe, Maybe(..))
-import Data.Tuple (uncurry, Tuple(..))
+import Data.Tuple (Tuple(..))
 import Effect.Aff (Aff)
 import Halogen as H
 import Halogen.HTML as HH
 import Halogen.HTML.Events as HE
 import Halogen.HTML.Properties as HP
 import Halogen.Query.Event (eventListener)
+import Halogen.Query.HalogenM as HM
 import Web.HTML (window) as Web
 import Web.HTML.Common (ClassName(..))
 import Web.HTML.HTMLDocument as HTMLDocument
@@ -34,7 +36,7 @@ data Event = LoadThumbs
     | Zoom
     | Unzoom
     | Pan Boolean -- True if right
-    | DownloadImages (Array Int)
+    | DownloadImage Int
     | Init
     | RegisterListeners
 
@@ -42,7 +44,7 @@ component :: forall query input. Model -> H.Component query input Event Aff
 component initialState = H.mkComponent
     { initialState: \_ -> initialState
     , render
-    , eval: H.mkEval $ H.defaultEval { handleAction = update, initialize = Just Init }
+    , eval: H.mkEval $ H.defaultEval { handleAction = wrapUpdate update', initialize = Just Init }
     }
 
 backgroundUrl :: String -> String
@@ -157,15 +159,11 @@ setThumb newThumb = setImage \i -> i{thumb = newThumb}
 setFull :: ImageData -> Int -> Model -> Model
 setFull newImage = setImage \i -> i{full = newImage}
 
-fetchThumbAction :: Int -> Image -> H.HalogenM Model Event () Event Aff Unit
+fetchThumbAction :: Int -> Image -> Aff Event
-fetchThumbAction position image = do
+fetchThumbAction position image = fetchThumb image <#> ThumbLoaded position
-    newData <- H.liftAff $ fetchThumb image
-    update $ ThumbLoaded position newData
 
-fetchFullAction :: Int -> Image -> H.HalogenM Model Event () Event Aff Unit
+fetchFullAction :: Int -> Image -> Aff Event
-fetchFullAction position image = do
+fetchFullAction position image = fetchFull image <#> FullLoaded position
-    newData <- H.liftAff $ fetchFull image
-    update $ FullLoaded position newData
 
 eventByKey :: KE.KeyboardEvent -> Maybe Event
 eventByKey ev = case KE.key ev of
@@ -179,61 +177,54 @@ focusedIndex :: Model -> Maybe Int
 focusedIndex (GLoaded { focus: Just { imageIndex } }) = Just imageIndex
 focusedIndex _ = Nothing
 
-update :: Event -> H.HalogenM Model Event () Event Aff Unit
+data UpdateResult
-update Init = update RegisterListeners <> update LoadThumbs
+    = Modify Model
-update RegisterListeners = do
+    | Affect (Array (Aff Event))
+    | Both (Array (Aff Event)) Model
+updateResultToTuple :: Model -> UpdateResult -> Tuple (Array (Aff Event)) Model
+updateResultToTuple _ (Modify m) = Tuple [] m
+updateResultToTuple m (Affect a) = Tuple a m
+updateResultToTuple _ (Both a m) = Tuple a m
+
+wrapUpdate :: (Event -> Model -> UpdateResult) -> Event -> H.HalogenM Model Event () Event Aff Unit
+wrapUpdate _ RegisterListeners = do
     document <- H.liftEffect $ Web.document =<< Web.window
     H.subscribe' \_ ->
       eventListener
         KET.keydown
         (HTMLDocument.toEventTarget document)
         (KE.fromEvent >>> (=<<) eventByKey)
-update LoadThumbs = do
+wrapUpdate inner event = do
-    model <- H.get
+    affects <- H.HalogenM $ liftF $ HM.State (\m -> updateResultToTuple m $ update' event m)
-    case model of
+    let wrapAff :: Aff Event -> H.HalogenM Model Event () Event Aff Unit
-        GError _ -> pure unit
+        wrapAff = H.liftAff >>> (=<<) (wrapUpdate inner)
-        GLoaded {images} -> parSequence_ $ mapWithIndex fetchThumbAction images
+    parSequence_ $ affects <#> wrapAff
-update (ThumbLoaded pos newData) = H.modify_ $ setThumb newData pos
-update (FullLoaded pos newData) = H.modify_ $ setFull newData pos
-update (Focus imageIndex) =  do
-    _ <- H.modify_ \model -> case model of
-        GError e -> GError e
-        GLoaded gal -> GLoaded gal{ focus = Just { imageIndex, zoom: false } }
-    _ <- update $ DownloadImages [imageIndex]
-    update $ DownloadImages [imageIndex - 1, imageIndex + 1]
-update Unfocus = H.modify_ \model -> case model of
-    GError e -> GError e
-    GLoaded gal -> GLoaded gal { focus = Nothing }
-update Zoom = H.modify_ \model -> case model of
-    GError e -> GError e
-    GLoaded gal -> GLoaded gal { focus = gal.focus <#> _{ zoom = true } }
-update Unzoom = H.modify_ \model -> case model of
-    GError e -> GError e
-    GLoaded gal -> GLoaded gal { focus = gal.focus <#> _{ zoom = false } }
-update (Pan right) = let offset = if right then 1 else -1 in do
-    _ <- H.modify_ \model -> case model of
-        GError e -> GError e
-        GLoaded gal -> GLoaded gal
-            { focus = gal.focus <#> \foc ->
-                foc{ imageIndex =
-                    mod (foc.imageIndex + offset) (length gal.images)
-                }
-            }
-    focus <- H.get <#> focusedIndex
-    let generateIndicies :: Int -> Array Int
-        generateIndicies = pure >>> (<*>) [identity, (+) offset]
-    let maybeEvent = focus <#> generateIndicies <#> DownloadImages
-    maybe (pure unit) update maybeEvent
-update (DownloadImages indicies) = do
-    model <- H.get
-    case model of
-        GLoaded { images } ->
-            parSequence_ $ indicies
-                # (<$>) (\i -> mod i (length images))
-                # mapMaybe (\i -> index images i <#> Tuple i)
-                <#> uncurry fetchFullAction
-        _ -> pure unit
 
+update' :: Event -> Model -> UpdateResult
+update' Init _ = Affect $ [RegisterListeners, LoadThumbs] <#> pure
+update' LoadThumbs (GLoaded {images}) =
+    Affect $ mapWithIndex fetchThumbAction images
+update' (ThumbLoaded pos newData) m = Modify $ setThumb newData pos m
+update' (FullLoaded pos newData) m = Modify $ setFull newData pos m
+update' (Focus imageIndex) (GLoaded gal) = Both
+    ([DownloadImage >>> pure] <*> [imageIndex, imageIndex - 1, imageIndex + 1])
+    (GLoaded gal{ focus = Just { imageIndex, zoom: false } })
+update' Unfocus (GLoaded gal) = Modify $ GLoaded gal{ focus = Nothing }
+update' Zoom (GLoaded gal) = Modify $ GLoaded gal{ focus = gal.focus <#> _{ zoom = true } }
+update' Unzoom (GLoaded gal) = Modify $ GLoaded gal { focus = gal.focus <#> _{ zoom = false } }
+update' (Pan right) (GLoaded gal@{images, focus: Just { imageIndex }}) =
+    let offset = if right then 1 else -1
+        newImageIndex = mod (imageIndex + offset) (length images) in
+    Both
+        [ pure $ DownloadImage $ (offset + newImageIndex) ]
+        (GLoaded gal{ focus = Just {imageIndex: newImageIndex, zoom: false }})
+update' (DownloadImage indx) (GLoaded { images }) =
+    let revisedIndex = mod indx (length images)
+        maybeImageData = index images revisedIndex in
+    case maybeImageData of
+        Just imageData -> Affect [fetchFullAction revisedIndex imageData]
+        Nothing -> Modify $ GError $ UnexpectedError "Despite taking the modulo, still invalid index"
+update' _ modl = Modify modl
 
 render :: forall m. Model -> H.ComponentHTML Event () m
 render (GError e) = HH.div