aviary-ps/src/UI.purs

module Aviary.UI where

import Prelude

import Aviary.Logic (fetchFull, fetchThumb)
import Aviary.Model (GalleryError(..), Image, ImageData(..), Model(..))

import Control.Parallel (parSequence_)
import Data.Array (mapWithIndex, modifyAt)
import Data.Maybe (maybe, Maybe(..))
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 Web.HTML.Common (ClassName(..))

data Event = LoadThumbs
    | ThumbLoaded Int ImageData
    | Focus Image

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 LoadThumbs }
    }

placeholderBlurhash :: forall r i. String -> HH.IProp r i
placeholderBlurhash = HH.attr (HH.AttrName "data-blurhash")

renderThumbnail :: forall m. Image -> H.ComponentHTML Event () m
renderThumbnail image =
    HH.div
        [ HP.class_ $ ClassName "thumbnail-card"
        , HE.onClick \_ -> Focus image
        ]
        ( [ HH.img
            ( [ placeholderBlurhash image.blurhash
                , HP.width 400
                , HP.height 400
            ] <> case image.thumb of
                ILoaded url -> [HP.src url]
                _ -> []
            )
        ] <> case image.thumb of
            Unloaded _ -> [HH.p_ [HH.text "Loading..."]]
            IError e -> [HH.p_ [HH.text $ "Error!  " <> (show e)]]
            _ -> []
        )

renderFocused :: forall m. Image -> H.ComponentHTML Event () m
renderFocused {blurhash, full} =
    HH.div
        [ HP.class_ $ ClassName "focused-panel"
        , HP.class_ $ ClassName "visible"
        ]
        ( [ HH.img
            ( [ placeholderBlurhash blurhash ]
            <> case full of
                ILoaded url -> [HP.src url]
                _ -> []
            )
        ] <> case full of
            Unloaded _ -> [HH.p_ [HH.text "Loading..."]]
            IError e -> [HH.p_ [HH.text $ "Error!  " <> (show e)]]
            _ -> []
        )

setThumb :: Int -> ImageData -> Model -> Model
setThumb pos newThumb (GLoaded title desc images focus) =
    case modifyAt pos (\i -> i{thumb=newThumb}) images of
        Just newImages -> GLoaded title desc newImages focus
        Nothing -> GError $ UnexpectedError "setThumb called with an invalid index!"
setThumb _ _ model = model

fetchThumbAction :: Int -> Image -> H.HalogenM Model Event () Event Aff Unit
fetchThumbAction position image = do
    newData <- H.liftAff $ fetchThumb image
    update $ ThumbLoaded position newData

update :: Event -> H.HalogenM Model Event () Event Aff Unit
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 pos newData
update (Focus newFocus) =
    ( H.modify_ \model -> case model of
        GError e -> GError e
        GLoaded title desc images _ -> GLoaded title desc images (Just newFocus)
    ) <> ( do
        newData <- H.liftAff $ fetchFull newFocus
        H.modify_ \m -> case m of
            GError e -> GError e
            GLoaded title desc images Nothing -> GLoaded title desc images Nothing
            GLoaded title desc images (Just focus) ->
                GLoaded title desc images (Just focus{full=newData})
    )

render :: forall m. Model -> H.ComponentHTML Event () m
render (GError e) = 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)    <>
    (renderThumbnail <$> images) <>
    (maybe [] (renderFocused >>> pure) focus))