From 95fc1b912ea22693676f71be4d1512d5b4d40c08 Mon Sep 17 00:00:00 2001 From: Emi Simpson Date: Tue, 15 Nov 2022 20:47:21 -0500 Subject: [PATCH] Refactored update to be more pure --- spago.dhall | 1 + src/UI.purs | 111 ++++++++++++++++++++++++---------------------------- 2 files changed, 52 insertions(+), 60 deletions(-) diff --git a/spago.dhall b/spago.dhall index e30bbd4..ba392de 100644 --- a/spago.dhall +++ b/spago.dhall @@ -24,6 +24,7 @@ to generate this file without the comments in this block. , "exceptions" , "fetch" , "filterable" + , "free" , "halogen" , "maybe" , "newtype" diff --git a/src/UI.purs b/src/UI.purs index 06dd117..6644cd7 100644 --- a/src/UI.purs +++ b/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 position image = do - newData <- H.liftAff $ fetchThumb image - update $ ThumbLoaded position newData +fetchThumbAction :: Int -> Image -> Aff Event +fetchThumbAction position image = fetchThumb image <#> ThumbLoaded position -fetchFullAction :: Int -> Image -> H.HalogenM Model Event () Event Aff Unit -fetchFullAction position image = do - newData <- H.liftAff $ fetchFull image - update $ FullLoaded position newData +fetchFullAction :: Int -> Image -> Aff Event +fetchFullAction position image = fetchFull image <#> FullLoaded position 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 -update Init = update RegisterListeners <> update LoadThumbs -update RegisterListeners = do +data UpdateResult + = Modify Model + | 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 - model <- H.get - case model of - GError _ -> pure unit - GLoaded {images} -> parSequence_ $ mapWithIndex fetchThumbAction images -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 +wrapUpdate inner event = do + affects <- H.HalogenM $ liftF $ HM.State (\m -> updateResultToTuple m $ update' event m) + let wrapAff :: Aff Event -> H.HalogenM Model Event () Event Aff Unit + wrapAff = H.liftAff >>> (=<<) (wrapUpdate inner) + parSequence_ $ affects <#> wrapAff +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