Refactored the model, preventing redundant requests of full images
This commit is contained in:
parent
ff526005aa
commit
52bbf8379b
|
@ -65,7 +65,12 @@ convertIndexFromProtobuf protoindex =
|
||||||
let {right: images, left: imagesErrors} = partitionMap convertImageFromProtobuf protoindex'.images
|
let {right: images, left: imagesErrors} = partitionMap convertImageFromProtobuf protoindex'.images
|
||||||
in
|
in
|
||||||
case head imagesErrors of
|
case head imagesErrors of
|
||||||
Nothing -> GLoaded protoindex'.title protoindex'.desc images Nothing
|
Nothing -> GLoaded
|
||||||
|
{ title: protoindex'.title
|
||||||
|
, desc: protoindex'.desc
|
||||||
|
, images
|
||||||
|
, focus: Nothing
|
||||||
|
}
|
||||||
Just err -> GError err
|
Just err -> GError err
|
||||||
|
|
||||||
parseIndex :: ArrayBuffer -> Effect Model
|
parseIndex :: ArrayBuffer -> Effect Model
|
||||||
|
|
|
@ -5,7 +5,7 @@ import Prelude
|
||||||
import AviaryFormat.Format (Format(..)) as Format
|
import AviaryFormat.Format (Format(..)) as Format
|
||||||
|
|
||||||
import Crypto.Subtle.Key.Types (CryptoKey)
|
import Crypto.Subtle.Key.Types (CryptoKey)
|
||||||
import Data.Maybe (Maybe(..))
|
import Data.Maybe (Maybe)
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
|
|
||||||
data GalleryError
|
data GalleryError
|
||||||
|
@ -43,13 +43,16 @@ type Image =
|
||||||
, full :: ImageData
|
, full :: ImageData
|
||||||
}
|
}
|
||||||
|
|
||||||
|
type LoadedGallery =
|
||||||
|
{ title :: Maybe String
|
||||||
|
, desc :: Maybe String
|
||||||
|
, images :: Array Image
|
||||||
|
, focus :: Maybe Int
|
||||||
|
}
|
||||||
|
|
||||||
data Model
|
data Model
|
||||||
= GError GalleryError
|
= GError GalleryError
|
||||||
| GLoaded
|
| GLoaded LoadedGallery
|
||||||
(Maybe String) -- Title
|
|
||||||
(Maybe String) -- Description
|
|
||||||
(Array Image) -- Images
|
|
||||||
(Maybe Image) -- Focused image
|
|
||||||
|
|
||||||
instance showGalleryError :: Show GalleryError where
|
instance showGalleryError :: Show GalleryError where
|
||||||
show (UnexpectedError message) =
|
show (UnexpectedError message) =
|
||||||
|
|
68
src/UI.purs
68
src/UI.purs
|
@ -6,7 +6,7 @@ import Aviary.Logic (fetchFull, fetchThumb)
|
||||||
import Aviary.Model (GalleryError(..), Image, ImageData(..), Model(..))
|
import Aviary.Model (GalleryError(..), Image, ImageData(..), Model(..))
|
||||||
|
|
||||||
import Control.Parallel (parSequence_)
|
import Control.Parallel (parSequence_)
|
||||||
import Data.Array (mapWithIndex, modifyAt)
|
import Data.Array (index, mapWithIndex, modifyAt)
|
||||||
import Data.Maybe (maybe, Maybe(..))
|
import Data.Maybe (maybe, Maybe(..))
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
import Halogen as H
|
import Halogen as H
|
||||||
|
@ -17,7 +17,8 @@ import Web.HTML.Common (ClassName(..))
|
||||||
|
|
||||||
data Event = LoadThumbs
|
data Event = LoadThumbs
|
||||||
| ThumbLoaded Int ImageData
|
| ThumbLoaded Int ImageData
|
||||||
| Focus Image
|
| FullLoaded Int ImageData
|
||||||
|
| Focus Int
|
||||||
|
|
||||||
component :: forall query input. Model -> H.Component query input Event Aff
|
component :: forall query input. Model -> H.Component query input Event Aff
|
||||||
component initialState = H.mkComponent
|
component initialState = H.mkComponent
|
||||||
|
@ -29,11 +30,11 @@ component initialState = H.mkComponent
|
||||||
placeholderBlurhash :: forall r i. String -> HH.IProp r i
|
placeholderBlurhash :: forall r i. String -> HH.IProp r i
|
||||||
placeholderBlurhash = HH.attr (HH.AttrName "data-blurhash")
|
placeholderBlurhash = HH.attr (HH.AttrName "data-blurhash")
|
||||||
|
|
||||||
renderThumbnail :: forall m. Image -> H.ComponentHTML Event () m
|
renderThumbnail :: forall m. Int -> Image -> H.ComponentHTML Event () m
|
||||||
renderThumbnail image =
|
renderThumbnail pos image =
|
||||||
HH.div
|
HH.div
|
||||||
[ HP.class_ $ ClassName "thumbnail-card"
|
[ HP.class_ $ ClassName "thumbnail-card"
|
||||||
, HE.onClick \_ -> Focus image
|
, HE.onClick \_ -> Focus pos
|
||||||
]
|
]
|
||||||
( [ HH.img
|
( [ HH.img
|
||||||
( [ placeholderBlurhash image.blurhash
|
( [ placeholderBlurhash image.blurhash
|
||||||
|
@ -67,42 +68,55 @@ renderFocused {blurhash, full} =
|
||||||
_ -> []
|
_ -> []
|
||||||
)
|
)
|
||||||
|
|
||||||
setThumb :: Int -> ImageData -> Model -> Model
|
setImage :: (Image -> Image) -> Int -> Model -> Model
|
||||||
setThumb pos newThumb (GLoaded title desc images focus) =
|
setImage _ _ (GError e) = (GError e)
|
||||||
case modifyAt pos (\i -> i{thumb=newThumb}) images of
|
setImage tranformation pos (GLoaded gallery) =
|
||||||
Just newImages -> GLoaded title desc newImages focus
|
case modifyAt pos tranformation gallery.images of
|
||||||
Nothing -> GError $ UnexpectedError "setThumb called with an invalid index!"
|
Just newImages -> GLoaded gallery{images = newImages}
|
||||||
setThumb _ _ model = model
|
Nothing -> GError $ UnexpectedError "setImage called with an out of bounds index!"
|
||||||
|
|
||||||
|
setThumb :: ImageData -> Int -> Model -> Model
|
||||||
|
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 -> H.HalogenM Model Event () Event Aff Unit
|
||||||
fetchThumbAction position image = do
|
fetchThumbAction position image = do
|
||||||
newData <- H.liftAff $ fetchThumb image
|
newData <- H.liftAff $ fetchThumb image
|
||||||
update $ ThumbLoaded position newData
|
update $ ThumbLoaded position newData
|
||||||
|
|
||||||
|
fetchFullAction :: Int -> Image -> H.HalogenM Model Event () Event Aff Unit
|
||||||
|
fetchFullAction position image = do
|
||||||
|
newData <- H.liftAff $ fetchFull image
|
||||||
|
update $ FullLoaded position newData
|
||||||
|
|
||||||
update :: Event -> H.HalogenM Model Event () Event Aff Unit
|
update :: Event -> H.HalogenM Model Event () Event Aff Unit
|
||||||
update LoadThumbs = do
|
update LoadThumbs = do
|
||||||
model <- H.get
|
model <- H.get
|
||||||
case model of
|
case model of
|
||||||
GError _ -> pure unit
|
GError _ -> pure unit
|
||||||
GLoaded _ _ images _ -> parSequence_ $ mapWithIndex fetchThumbAction images
|
GLoaded {images} -> parSequence_ $ mapWithIndex fetchThumbAction images
|
||||||
update (ThumbLoaded pos newData) = H.modify_ $ setThumb pos newData
|
update (ThumbLoaded pos newData) = H.modify_ $ setThumb newData pos
|
||||||
update (Focus newFocus) =
|
update (FullLoaded pos newData) = H.modify_ $ setFull newData pos
|
||||||
( H.modify_ \model -> case model of
|
update (Focus newFocus) = do
|
||||||
|
_ <- H.modify_ \model -> case model of
|
||||||
GError e -> GError e
|
GError e -> GError e
|
||||||
GLoaded title desc images _ -> GLoaded title desc images (Just newFocus)
|
GLoaded gal -> GLoaded gal{ focus = Just newFocus }
|
||||||
) <> ( do
|
model <- H.get
|
||||||
newData <- H.liftAff $ fetchFull newFocus
|
case model of
|
||||||
H.modify_ \m -> case m of
|
GError _ -> pure unit
|
||||||
GError e -> GError e
|
GLoaded gal ->
|
||||||
GLoaded title desc images Nothing -> GLoaded title desc images Nothing
|
let focusedImage = index gal.images newFocus
|
||||||
GLoaded title desc images (Just focus) ->
|
in case focusedImage of
|
||||||
GLoaded title desc images (Just focus{full=newData})
|
Just focusedImage' -> fetchFullAction newFocus focusedImage'
|
||||||
)
|
Nothing ->
|
||||||
|
H.put $ GError $ UnexpectedError "Focus event raised with an out of bounds index!"
|
||||||
|
|
||||||
render :: forall m. Model -> H.ComponentHTML Event () m
|
render :: forall m. Model -> H.ComponentHTML Event () m
|
||||||
render (GError e) = HH.p_ [ HH.text $ show e ]
|
render (GError e) = HH.p_ [ HH.text $ show e ]
|
||||||
render (GLoaded title desc images focus) = HH.div_
|
render (GLoaded {title, desc, images, focus}) = HH.div_
|
||||||
((maybe [] (HH.text >>> pure >>> HH.h1_ >>> pure) title) <>
|
((maybe [] (HH.text >>> pure >>> HH.h1_ >>> pure) title) <>
|
||||||
(maybe [] (HH.text >>> pure >>> HH.p_ >>> pure) desc) <>
|
(maybe [] (HH.text >>> pure >>> HH.p_ >>> pure) desc) <>
|
||||||
(renderThumbnail <$> images) <>
|
(mapWithIndex renderThumbnail images) <>
|
||||||
(maybe [] (renderFocused >>> pure) focus))
|
(maybe [] (renderFocused >>> pure) (index images =<< focus)))
|
||||||
|
|
Loading…
Reference in New Issue