295 lines
11 KiB
Plaintext
295 lines
11 KiB
Plaintext
module Aviary.UI where
|
||
|
||
import Prelude
|
||
|
||
import Aviary.Logic (fetchFull, fetchThumb)
|
||
import Aviary.Model ( GalleryError(..)
|
||
, Image
|
||
, ImageData(..)
|
||
, LoadedGallery
|
||
, Model(..)
|
||
)
|
||
|
||
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(..))
|
||
import Effect.Aff (Aff, delay)
|
||
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
|
||
import Web.HTML.Window (document) as Web
|
||
import Web.UIEvent.KeyboardEvent as KE
|
||
import Web.UIEvent.KeyboardEvent.EventTypes as KET
|
||
|
||
failCooldown :: Milliseconds
|
||
failCooldown = Milliseconds 10000.0
|
||
|
||
data Event = LoadThumbs
|
||
| ImgUpdate Boolean Int ImageData -- isThumb, index, data
|
||
| Focus Int
|
||
| Unfocus
|
||
| Zoom
|
||
| Unzoom
|
||
| Pan Boolean -- True if right
|
||
| DownloadImage Int
|
||
| Init
|
||
| RegisterListeners
|
||
|
||
component :: forall query input. Model -> H.Component query input Event Aff
|
||
component initialState = H.mkComponent
|
||
{ initialState: \_ -> initialState
|
||
, render
|
||
, eval: H.mkEval $ H.defaultEval { handleAction = wrapUpdate update', initialize = Just Init }
|
||
}
|
||
|
||
backgroundUrl :: String -> String
|
||
backgroundUrl url = "background-image: url(" <> url <> ");"
|
||
|
||
widthHeight :: Int -> Int -> String
|
||
widthHeight w h = "width:" <> (show w) <> "px;height:" <> (show h) <> "px;"
|
||
|
||
renderThumbnail :: forall m. Int -> Image -> H.ComponentHTML Event () m
|
||
renderThumbnail pos image =
|
||
HH.button
|
||
(
|
||
[ HP.classes $ ClassName <$> ["thumbnail-card", "blurhash-frame", "control"]
|
||
, HE.onClick \_ -> Focus pos
|
||
]
|
||
<>
|
||
maybe [] (backgroundUrl >>> HP.style >>> pure) (image.blurhashUrl)
|
||
)
|
||
case image.thumb of
|
||
Unloaded _ -> []
|
||
Loading ->
|
||
[ HH.span
|
||
[ HP.class_ $ ClassName "loading-msg"
|
||
]
|
||
[ HH.text "Loading..."
|
||
]
|
||
]
|
||
Retrying _ e ->
|
||
[ HH.span
|
||
[ HP.class_ $ ClassName "error-msg"
|
||
]
|
||
[ HH.text $ "Error! " <> (show e)
|
||
]
|
||
]
|
||
IError e ->
|
||
[ HH.span
|
||
[ HP.class_ $ ClassName "error-msg"
|
||
]
|
||
[ HH.text $ "Error! " <> (show e)
|
||
]
|
||
]
|
||
ILoaded url ->
|
||
[ HH.img [HP.src url]
|
||
]
|
||
|
||
renderFocused :: forall m. Boolean -> Image -> H.ComponentHTML Event () m
|
||
renderFocused zoom image =
|
||
HH.div
|
||
[ HP.id "focused-panel"
|
||
, HP.class_ $ ClassName if zoom then "zoomed" else "unzoomed"
|
||
]
|
||
[ HH.div
|
||
[ HP.id "focused-bg"
|
||
, HE.onClick \_ -> Unfocus
|
||
]
|
||
[ HH.button
|
||
[ HP.id "close"
|
||
, HP.class_ $ ClassName "control"
|
||
]
|
||
[ HH.text "⨯"
|
||
]
|
||
]
|
||
, HH.button
|
||
[ HP.id "prev-image"
|
||
, HP.class_ $ ClassName "control"
|
||
, HE.onClick \_ -> Pan false
|
||
]
|
||
[ HH.text "❰"
|
||
]
|
||
, HH.button
|
||
[ HP.id "next-image"
|
||
, HP.class_ $ ClassName "control"
|
||
, HE.onClick \_ -> Pan true
|
||
]
|
||
[ HH.text "❱"
|
||
]
|
||
, HH.div
|
||
[ HP.style
|
||
case image.full of
|
||
ILoaded _ -> ""
|
||
_ ->
|
||
( maybe "" backgroundUrl (image.blurhashUrl)
|
||
<> widthHeight image.width image.height
|
||
)
|
||
, HP.class_ $ ClassName "blurhash-frame"
|
||
]
|
||
case image.full of
|
||
Unloaded _ -> []
|
||
Loading ->
|
||
[ HH.span
|
||
[ HP.class_ $ ClassName "loading-msg"
|
||
]
|
||
[ HH.text "Loading..."
|
||
]
|
||
]
|
||
IError e ->
|
||
[ HH.span
|
||
[ HP.class_ $ ClassName "error-msg"
|
||
]
|
||
[ HH.text $ "Error! " <> (show e)
|
||
]
|
||
]
|
||
Retrying _ e ->
|
||
[ HH.span
|
||
[ HP.class_ $ ClassName "error-msg"
|
||
]
|
||
[ HH.text $ "Error! " <> (show e)
|
||
]
|
||
]
|
||
ILoaded url ->
|
||
[ HH.img
|
||
[ HP.src url
|
||
, HE.onClick \_ -> if zoom then Unzoom else Zoom
|
||
]
|
||
]
|
||
]
|
||
|
||
setImage :: (Image -> Image) -> Int -> LoadedGallery -> Model
|
||
setImage tranformation pos gallery =
|
||
case modifyAt pos tranformation gallery.images of
|
||
Just newImages -> GLoaded gallery{images = newImages}
|
||
Nothing -> GError $ UnexpectedError "setImage called with an out of bounds index!"
|
||
|
||
setThumb :: ImageData -> Int -> LoadedGallery -> Model
|
||
setThumb newThumb = setImage \i -> i{thumb = newThumb}
|
||
|
||
setFull :: ImageData -> Int -> LoadedGallery -> Model
|
||
setFull newImage = setImage \i -> i{full = newImage}
|
||
|
||
fetchThumbAction :: Int -> Image -> Aff Event
|
||
fetchThumbAction position image = fetchThumb image <#> ImgUpdate true position
|
||
|
||
fetchFullAction :: Int -> Image -> Aff Event
|
||
fetchFullAction position image = fetchFull image <#> ImgUpdate false position
|
||
|
||
eventByKey :: KE.KeyboardEvent -> Maybe Event
|
||
eventByKey ev = case KE.key ev of
|
||
"ArrowLeft" -> Just $ Pan false
|
||
"ArrowRight" -> Just $ Pan true
|
||
"Escape" -> Just $ Unfocus
|
||
"1" -> Just $ Focus 0
|
||
_ -> Nothing
|
||
|
||
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 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
|
||
|
||
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)
|
||
wrapUpdate inner event = do
|
||
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)
|
||
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 $ Seq $ [RegisterListeners, LoadThumbs] <#> pure
|
||
update' LoadThumbs (GLoaded {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
|
||
(GLoaded {images}) -> index images pos
|
||
_ -> Nothing
|
||
retryAction = \img -> do
|
||
let fetch = if isThumb then fetchThumbAction else fetchFullAction
|
||
_ <- delay failCooldown
|
||
fetch pos img
|
||
in case newData, updatedImage of
|
||
(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
|
||
(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 } }
|
||
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
|
||
(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)
|
||
maybeImageData = index images revisedIndex in
|
||
case maybeImageData of
|
||
Just imageData -> case modifyAt revisedIndex _{full = Loading} images of
|
||
Just newImages -> Both
|
||
(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"
|
||
update' _ modl = Modify modl
|
||
|
||
render :: forall m. Model -> H.ComponentHTML Event () m
|
||
render (GError e) = HH.div
|
||
[ HP.class_ $ ClassName "uh-oh-stinky"
|
||
]
|
||
[ HH.p_ [ HH.text $ show e ]
|
||
]
|
||
render (GLoaded {title, desc, images, focus}) = HH.div_
|
||
((maybe [] (HH.text >>> pure >>> HH.h1_ >>> pure) title) <>
|
||
(maybe [] (HH.text >>> pure >>> HH.p_ >>> pure) desc) <>
|
||
[ HH.div
|
||
[ HP.id "thumbnails"
|
||
]
|
||
(mapWithIndex renderThumbnail images)
|
||
] <>
|
||
(maybe [] (renderFocused (fromMaybe false (_.zoom <$> focus)) >>> pure) (index images =<< (_.imageIndex <$> focus))))
|