Refactored some code out of the UI module
This commit is contained in:
parent
4d8d6ee8e0
commit
eef0a5a653
|
@ -5,7 +5,8 @@ import Prelude
|
||||||
import AviaryFormat.Format (Format(..)) as Format
|
import AviaryFormat.Format (Format(..)) as Format
|
||||||
|
|
||||||
import Crypto.Subtle.Key.Types (CryptoKey)
|
import Crypto.Subtle.Key.Types (CryptoKey)
|
||||||
import Data.Maybe (Maybe)
|
import Data.Array (modifyAt)
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
|
|
||||||
data GalleryError
|
data GalleryError
|
||||||
|
@ -71,6 +72,22 @@ data Model
|
||||||
= GError GalleryError
|
= GError GalleryError
|
||||||
| GLoaded LoadedGallery
|
| GLoaded LoadedGallery
|
||||||
|
|
||||||
|
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}
|
||||||
|
|
||||||
|
focusedIndex :: Model -> Maybe Int
|
||||||
|
focusedIndex (GLoaded { focus: Just { imageIndex } }) = Just imageIndex
|
||||||
|
focusedIndex _ = Nothing
|
||||||
|
|
||||||
instance showGalleryError :: Show GalleryError where
|
instance showGalleryError :: Show GalleryError where
|
||||||
show (UnexpectedError message) =
|
show (UnexpectedError message) =
|
||||||
"Something that should be impossible just happened! Please open up a new issue "
|
"Something that should be impossible just happened! Please open up a new issue "
|
||||||
|
|
|
@ -0,0 +1,140 @@
|
||||||
|
module Aviary.Switchboard where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Aviary.Logic (fetchFull, fetchThumb)
|
||||||
|
import Aviary.Model ( GalleryError(..)
|
||||||
|
, Image
|
||||||
|
, ImageData(..)
|
||||||
|
, Model(..)
|
||||||
|
, setFull
|
||||||
|
, setThumb
|
||||||
|
)
|
||||||
|
|
||||||
|
import Control.Parallel (parSequence_)
|
||||||
|
import Control.Monad.Free (liftF)
|
||||||
|
import Data.Array (index, length, mapWithIndex, modifyAt)
|
||||||
|
import Data.Foldable (fold)
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
|
import Data.Tuple (Tuple(..))
|
||||||
|
import Data.Time.Duration (Milliseconds(..))
|
||||||
|
import Effect.Aff (Aff, delay)
|
||||||
|
import Halogen as H
|
||||||
|
import Halogen.Query.Event (eventListener)
|
||||||
|
import Halogen.Query.HalogenM as HM
|
||||||
|
import Web.HTML (window) as Web
|
||||||
|
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
|
||||||
|
| ImgUpdate Boolean Int ImageData -- isThumb, index, data
|
||||||
|
| Focus Int
|
||||||
|
| Unfocus
|
||||||
|
| Zoom
|
||||||
|
| Unzoom
|
||||||
|
| Pan Boolean -- True if right
|
||||||
|
| DownloadImage Int
|
||||||
|
| Init
|
||||||
|
| RegisterListeners
|
||||||
|
|
||||||
|
failCooldown :: Milliseconds
|
||||||
|
failCooldown = Milliseconds 10000.0
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
update :: Event -> H.HalogenM Model Event () Event Aff Unit
|
||||||
|
update = wrapUpdate update'
|
148
src/UI.purs
148
src/UI.purs
|
@ -2,54 +2,26 @@ module Aviary.UI where
|
||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Aviary.Logic (fetchFull, fetchThumb)
|
import Aviary.Model ( Image
|
||||||
import Aviary.Model ( GalleryError(..)
|
|
||||||
, Image
|
|
||||||
, ImageData(..)
|
, ImageData(..)
|
||||||
, LoadedGallery
|
|
||||||
, Model(..)
|
, Model(..)
|
||||||
)
|
)
|
||||||
|
import Aviary.Switchboard (Event(..), update)
|
||||||
|
|
||||||
import Control.Parallel (parSequence_)
|
import Data.Array (index, mapWithIndex)
|
||||||
import Control.Monad.Free (liftF)
|
|
||||||
import Data.Array (index, length, mapWithIndex, modifyAt)
|
|
||||||
import Data.Foldable (fold)
|
|
||||||
import Data.Maybe (fromMaybe, maybe, Maybe(..))
|
import Data.Maybe (fromMaybe, maybe, Maybe(..))
|
||||||
import Data.Tuple (Tuple(..))
|
import Effect.Aff (Aff)
|
||||||
import Data.Time.Duration (Milliseconds(..))
|
|
||||||
import Effect.Aff (Aff, delay)
|
|
||||||
import Halogen as H
|
import Halogen as H
|
||||||
import Halogen.HTML as HH
|
import Halogen.HTML as HH
|
||||||
import Halogen.HTML.Events as HE
|
import Halogen.HTML.Events as HE
|
||||||
import Halogen.HTML.Properties as HP
|
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.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 :: forall query input. Model -> H.Component query input Event Aff
|
||||||
component initialState = H.mkComponent
|
component initialState = H.mkComponent
|
||||||
{ initialState: \_ -> initialState
|
{ initialState: \_ -> initialState
|
||||||
, render
|
, render
|
||||||
, eval: H.mkEval $ H.defaultEval { handleAction = wrapUpdate update', initialize = Just Init }
|
, eval: H.mkEval $ H.defaultEval { handleAction = update, initialize = Just Init }
|
||||||
}
|
}
|
||||||
|
|
||||||
backgroundUrl :: String -> String
|
backgroundUrl :: String -> String
|
||||||
|
@ -167,116 +139,6 @@ renderFocused zoom image =
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
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 :: forall m. Model -> H.ComponentHTML Event () m
|
||||||
render (GError e) = HH.div
|
render (GError e) = HH.div
|
||||||
[ HP.class_ $ ClassName "uh-oh-stinky"
|
[ HP.class_ $ ClassName "uh-oh-stinky"
|
||||||
|
|
Loading…
Reference in New Issue