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 Web.HTML.Common (ClassName(..))

data Event = LoadThumbs
    | ThumbLoaded Int ImageData
    | FullLoaded Int ImageData
    | Focus Int
    | Unfocus
    | Zoom
    | Unzoom
    | Pan Boolean -- True if right
    | DownloadFocused
    | Null

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

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.div
        (
            [ HP.classes $ ClassName <$> ["thumbnail-card", "blurhash-frame"]
            , 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.div
                [ HP.id "close"
                ]
                [ HH.text "⨯"
                ]
            ]
        , HH.div
            [ HP.id "prev-image"
            , HE.onClick \_ -> Pan false
            ]
            [ HH.text "❰"
            ]
        , HH.div
            [ HP.id "next-image"
            , 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

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 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
update Null = 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_
    -- [ HE.onKeyDown \e -> Log $ E.key e -- case E.key e of
    --     -- "ArrowRight" -> Pan true
    --     -- "ArrowLeft" -> Pan false
    -- ]
    -- Pending https://github.com/purescript-halogen/purescript-halogen/issues/806
    ((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))))