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