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 (index, length, mapWithIndex, modifyAt)
import Data.Maybe (fromMaybe, 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 Halogen.Query.Event (eventListener)
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

data Event = LoadThumbs
    | ThumbLoaded Int ImageData
    | FullLoaded Int ImageData
    | Focus Int
    | Unfocus
    | Zoom
    | Unzoom
    | Pan Boolean -- True if right
    | DownloadFocused
    | 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 = 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 _ ->
                [ HH.span
                    [ HP.class_ $ ClassName "loading-msg"
                    ]
                    [ HH.text "Loading..."
                    ]
                ]
            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 _ ->
                    [ HH.span
                        [ HP.class_ $ ClassName "loading-msg"
                        ]
                        [ HH.text "Loading..."
                        ]
                    ]
                IError 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 -> Model -> Model
setImage _ _ (GError e) = (GError e)
setImage tranformation pos (GLoaded 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 -> 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 position image = do
    newData <- H.liftAff $ fetchThumb image
    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

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

update :: Event -> H.HalogenM Model Event () Event Aff Unit
update Init = update RegisterListeners <> update LoadThumbs
update 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 DownloadFocused
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) = do
    _ <- H.modify_ \model -> case model of
        GError e -> GError e
        GLoaded gal -> GLoaded gal
            { focus = gal.focus <#> \foc ->
                foc{ imageIndex =
                    mod (foc.imageIndex + (if right then 1 else -1)) (length gal.images)
                }
            }
    update DownloadFocused
update DownloadFocused = do
    model <- H.get
    case model of
        GLoaded {images, focus: Just {imageIndex}} ->
            let focusedImage = index images imageIndex
            in case focusedImage of
                Just focusedImage' -> fetchFullAction imageIndex focusedImage'
                Nothing ->
                    H.put $ GError $ UnexpectedError "Focus event raised with an out of bounds index!"
        _ -> pure unit


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))))