diff --git a/spago.dhall b/spago.dhall index 6b67969..c4d0346 100644 --- a/spago.dhall +++ b/spago.dhall @@ -25,6 +25,7 @@ to generate this file without the comments in this block. , "exceptions" , "fetch" , "filterable" + , "foldable-traversable" , "free" , "halogen" , "maybe" diff --git a/src/UI.purs b/src/UI.purs index b87c290..6249402 100644 --- a/src/UI.purs +++ b/src/UI.purs @@ -13,6 +13,7 @@ import Aviary.Model ( GalleryError(..) import Control.Parallel (parSequence_) import Control.Monad.Free (liftF) import Data.Array (index, length, mapWithIndex, modifyAt) +import Data.Foldable (fold) import Data.Maybe (fromMaybe, maybe, Maybe(..)) import Data.Tuple (Tuple(..)) import Data.Time.Duration (Milliseconds(..)) @@ -196,12 +197,26 @@ focusedIndex :: Model -> Maybe Int focusedIndex (GLoaded { focus: Just { imageIndex } }) = Just imageIndex focusedIndex _ = Nothing +data AffectKind + = Parallel (Array (Aff Event)) + | Seq (Array (Aff Event)) + | Single (Aff Event) + +affArray :: AffectKind -> Array (Aff Event) +affArray (Parallel a) = a +affArray (Seq a) = a +affArray (Single a) = [a] + +isParallel :: AffectKind -> Boolean +isParallel (Parallel _) = true +isParallel _ = false + 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 + | Affect AffectKind + | Both AffectKind Model +updateResultToTuple :: Model -> UpdateResult -> Tuple AffectKind Model +updateResultToTuple _ (Modify m) = Tuple (Seq []) m updateResultToTuple m (Affect a) = Tuple a m updateResultToTuple _ (Both a m) = Tuple a m @@ -214,15 +229,17 @@ wrapUpdate _ RegisterListeners = do (HTMLDocument.toEventTarget document) (KE.fromEvent >>> (=<<) eventByKey) wrapUpdate inner event = do - affects <- H.HalogenM $ liftF $ HM.State (\m -> updateResultToTuple m $ update' event m) + affects <- H.HalogenM $ liftF $ HM.State (\m -> updateResultToTuple m $ inner event m) let wrapAff :: Aff Event -> H.HalogenM Model Event () Event Aff Unit wrapAff = H.liftAff >>> (=<<) (wrapUpdate inner) - parSequence_ $ affects <#> wrapAff + let runArray :: Array (H.HalogenM Model Event () Event Aff Unit) -> H.HalogenM Model Event () Event Aff Unit + runArray = if isParallel affects then parSequence_ else fold + runArray $ (affArray affects) <#> wrapAff update' :: Event -> Model -> UpdateResult -update' Init _ = Affect $ [RegisterListeners, LoadThumbs] <#> pure +update' Init _ = Affect $ Seq $ [RegisterListeners, LoadThumbs] <#> pure update' LoadThumbs (GLoaded {images}) = - Affect $ mapWithIndex fetchThumbAction images + Affect $ Parallel $ mapWithIndex fetchThumbAction images update' (ImgUpdate isThumb pos newData) (GLoaded gal) = let newGallery = (if isThumb then setThumb else setFull) newData pos gal updatedImage = case newGallery of @@ -233,11 +250,11 @@ update' (ImgUpdate isThumb pos newData) (GLoaded gal) = _ <- delay failCooldown fetch pos img in case newData, updatedImage of - (Retrying _ _), Just img -> Both [retryAction img] newGallery + (Retrying _ _), Just img -> Both (Single $ retryAction img) newGallery _, Nothing -> Modify $ GError $ UnexpectedError $ "Suprising out of bound index!" _, (Just _) -> Modify newGallery -- No fetch required update' (Focus imageIndex) (GLoaded gal) = Both - ([DownloadImage >>> pure] <*> [imageIndex, imageIndex + 1, imageIndex - 1]) + (Seq ([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 } } @@ -246,7 +263,7 @@ 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) ] + (Single $ pure $ DownloadImage $ (offset + newImageIndex)) (GLoaded gal{ focus = Just {imageIndex: newImageIndex, zoom: false }}) update' (DownloadImage indx) (GLoaded gal@{ images }) = let revisedIndex = mod indx (length images) @@ -254,7 +271,7 @@ update' (DownloadImage indx) (GLoaded gal@{ images }) = case maybeImageData of Just imageData -> case modifyAt revisedIndex _{full = Loading} images of Just newImages -> Both - [fetchFullAction revisedIndex imageData] + (Single $ fetchFullAction revisedIndex imageData) (GLoaded gal{ images = newImages }) Nothing -> Modify $ GError $ UnexpectedError "Valid position asserted by index and module declared invalid by index" Nothing -> Modify $ GError $ UnexpectedError "Despite taking the modulo, still invalid index"