aviary-ps/src/UI.purs

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