diff options
Diffstat (limited to 'Hero')
| -rw-r--r-- | Hero/Core.hs | 201 | ||||
| -rw-r--r-- | Hero/Host.hs | 43 | ||||
| -rw-r--r-- | Hero/Node.hs | 90 | ||||
| -rw-r--r-- | Hero/Part.hs | 3 |
4 files changed, 170 insertions, 167 deletions
diff --git a/Hero/Core.hs b/Hero/Core.hs index 9f67bd7..bc53503 100644 --- a/Hero/Core.hs +++ b/Hero/Core.hs @@ -25,9 +25,8 @@ import Data.Data (Data, Typeable) import qualified Data.List as List import qualified Data.List.Split as List import Data.Proxy (Proxy (..)) -import Data.String import Data.String.Quote -import Data.Text (Text, replace, toLower) +import Data.Text (Text) import GHC.Generics (Generic) import qualified GHC.Show as Legacy import Hero.Look as Look @@ -105,13 +104,13 @@ instance FromJSON User where -- | Class for rendering media objects in different ways. class IsMediaObject o where -- | Render a thumbnail for use in a shelf, or otherwise. - thumbnail :: o -> View Action + thumbnail :: o -> View Move -- | Render a featured banner. - feature :: o -> User -> View Action + feature :: o -> User -> View Move -- | Media info view - info :: o -> User -> View Action + info :: o -> User -> View Move -- | How much to Zoom the comic image type Magnification = Int @@ -122,24 +121,24 @@ data Button | Read Comic | Save Comic User | SaveIcon Comic User - | ZoomIcon Magnification Comic Page + | ZoomIcon Magnification Comic PageNumber | PlayPause MisoString AudioState - | Arrow Action + | Arrow Move -- | Class for defining general, widely used elements in the heroverse. -class Elemental v where el :: v -> View Action +class Elemental v where el :: v -> View Move -- TODO: what if I just did this on all actions? -- then I could e.g. `el $ ToggleAudio audioId audioState` instance Elemental Button where - el (PlayPause id model) = + el (PlayPause id form) = button_ [ class_ "button is-large icon", onClick $ ToggleAudio id ] [i_ [class_ $ "fa " <> icon] []] where - icon = case model of + icon = case form of Paused -> "fa-play-circle" Playing -> "fa-pause-circle" el (Arrow act) = @@ -181,7 +180,7 @@ instance Elemental Button where onClick $ ToggleInLibrary c ] [img_ [src_ $ ms $ Pack.demo <> "library-add.png"]] - el (ZoomIcon zmodel comic page) = + el (ZoomIcon zform comic page) = button_ [ id_ "zoom-button", class_ "button is-large", @@ -193,13 +192,13 @@ instance Elemental Button where min_ "0", max_ "100", disabled_ True, - value_ $ ms (show zmodel :: String), + value_ $ ms (show zform :: String), class_ "ctrl", id_ "zoom" ], label_ [class_ "ctrl", Miso.for_ "zoom"] - [text $ ms $ (show zmodel :: String) ++ "%"] + [text $ ms $ (show zform :: String) ++ "%"] ] el (Read c) = a_ @@ -220,20 +219,20 @@ data AudioState = Playing | Paused data ComicReaderState = NotReading | Cover ComicId - | ChooseExperience ComicId Page - | Reading ComicReaderView ComicId Page + | ChooseExperience ComicId PageNumber + | Reading ComicReaderView ComicId PageNumber | Watching ComicId deriving (Show, Eq) findComic :: ComicId -> [Comic] -> Maybe Comic findComic id = List.find (\c -> comicId c == id) --- | Main model for the app. +-- | Main form for the app. -- -- Try to prefix component-specific state with the component initials: 'd' for -- discover, 'cp' for comic player. -data Model - = Model +data Form + = Form { uri :: Api.URI, appComics :: RemoteData MisoString [Comic], user :: User, @@ -244,9 +243,9 @@ data Model } deriving (Show, Eq) -initModel :: Api.URI -> Model -initModel uri_ = - Model +initForm :: Api.URI -> Form +initForm uri_ = + Form { uri = uri_, appComics = NotAsked, dMediaInfo = Nothing, @@ -266,11 +265,11 @@ detectPlayerState u = case List.splitOn "/" $ Api.uriPath u of ["", "comic", id] -> Cover $ ComicId id _ -> NotReading where - toPage pg = fromMaybe 1 (readMaybe pg :: Maybe Page) + toPage pg = fromMaybe 1 (readMaybe pg :: Maybe PageNumber) -type Page = Int +type PageNumber = Int -data Action +data Move = NoOp | -- comic player stuff SelectExperience Comic @@ -278,7 +277,7 @@ data Action | StartWatching Comic | NextPage | PrevPage - | ToggleZoom Comic Page + | ToggleZoom Comic PageNumber | ToggleAudio MisoString | FetchComics | SetComics (RemoteData MisoString [Comic]) @@ -292,7 +291,7 @@ data Action ScrollIntoView MisoString | HandleURI Api.URI | ChangeURI Api.URI - | DumpModel + | Dumpform deriving (Show, Eq) type AppRoutes = @@ -328,18 +327,18 @@ pubRoutes = Proxy -- TODO: consider making a typeclass, something like: -- -- class Page name where --- type Route name :: View Action +-- type Route name :: View Move -- proxy :: Proxy name -- proxy = Proxy name --- view :: Model -> View Action +-- view :: form -> View Move -- link :: Api.URI --- * home +-- ** home -- -- this is the unauthenticated page that you see when you first visit type Home = - View Action + View Move homeProxy :: Proxy Home homeProxy = Proxy @@ -349,10 +348,10 @@ homeLink = linkURI $ Api.safeLink front homeProxy where front = Proxy :: Proxy Home -home :: Model -> View Action +home :: form -> View Move home = login --- * login +-- ** login data LoginForm = LoginForm {loginEmail :: String, loginPass :: String} deriving (Eq, Show, Read, Generic) @@ -362,7 +361,7 @@ instance ToJSON LoginForm instance FromJSON LoginForm type Login = - "login" :> View Action + "login" :> View Move loginProxy :: Proxy Login loginProxy = Proxy @@ -370,7 +369,7 @@ loginProxy = Proxy loginLink :: Api.URI loginLink = linkURI $ Api.safeLink pubRoutes loginProxy -login :: Model -> View Action +login :: form -> View Move login _ = template "login" @@ -414,9 +413,9 @@ login _ = fadeIn = "animated fadeIn delay-2s" ctrl x = div_ [class_ "control"] [input_ x] --- * discover +-- ** discover -type Discover = "discover" :> View Action +type Discover = "discover" :> View Move discoverLink :: Api.URI discoverLink = linkURI $ Api.safeLink routes discoverProxy @@ -424,12 +423,12 @@ discoverLink = linkURI $ Api.safeLink routes discoverProxy discoverProxy :: Proxy Discover discoverProxy = Proxy -discover :: Model -> View Action -discover model@Model {user = u} = +discover :: Form -> View Move +discover form@Form {user = u} = template "discover" [ topbar, - main_ [id_ "app-body"] $ case appComics model of + main_ [id_ "app-body"] $ case appComics form of NotAsked -> [loading] Loading -> [loading] Failure _ -> [nocomics] @@ -437,13 +436,13 @@ discover model@Model {user = u} = Success (comic : rest) -> [ feature comic u, shelf "Recent Releases" (comic : rest), - maybeView (`info` u) $ dMediaInfo model + maybeView (`info` u) $ dMediaInfo form ], appmenu, discoverFooter ] -discoverFooter :: View Action +discoverFooter :: View Move discoverFooter = footer_ [ id_ "app-foot", @@ -467,7 +466,7 @@ discoverFooter = p_ [] [text "-Stan Lee"] ], div_ - [css euro, id_ "app-foot-logo", onClick DumpModel] + [css euro, id_ "app-foot-logo", onClick Dumpform] [ a_ [class_ "social-icon", href_ "#"] [img_ [src_ $ ms $ Pack.icon <> "hero-logo.svg"]], span_ [] [text "© Hero Records, Inc. All Rights Reserved"] ] @@ -480,7 +479,7 @@ discoverFooter = (attrs lnk) [img_ [src_ $ ms $ Pack.cdnEdge <> "/old-assets/images/icons/" <> x]] --- * comic +-- ** comic data Comic = Comic @@ -578,35 +577,35 @@ instance IsMediaObject Comic where type ComicCover = "comic" :> Api.Capture "comicId" ComicId - :> View Action + :> View Move comicProxy :: Proxy ComicCover comicProxy = Proxy -comicCover :: ComicId -> Model -> View Action +comicCover :: ComicId -> Form -> View Move comicCover comicId_ = comicReader comicId_ 1 comicLink :: ComicId -> Api.URI comicLink comicId_ = linkURI $ Api.safeLink routes comicProxy comicId_ --- * chooseExperience +-- ** chooseExperience type ChooseExperience = "comic" :> Api.Capture "id" ComicId - :> Api.Capture "page" Page + :> Api.Capture "page" PageNumber :> "experience" - :> View Action + :> View Move chooseExperienceProxy :: Proxy ChooseExperience chooseExperienceProxy = Proxy -chooseExperienceLink :: ComicId -> Page -> Api.URI +chooseExperienceLink :: ComicId -> PageNumber -> Api.URI chooseExperienceLink id page = linkURI $ Api.safeLink routes chooseExperienceProxy id page -chooseExperiencePage :: Comic -> Page -> Model -> View Action -chooseExperiencePage comic page model = +chooseExperiencePage :: Comic -> PageNumber -> Form -> View Move +chooseExperiencePage comic page form = template "choose-experience" [ topbar, @@ -617,7 +616,7 @@ chooseExperiencePage comic page model = ul_ [] $ li comic </ experiences ], appmenu, - comicControls comic page model + comicControls comic page form ] where li c (name, artist, track) = @@ -650,27 +649,27 @@ dark, energetic or dramatic. Feeling indecisive? Let us navigate your journey with the original curated music for this piece of visual art. |] --- * comicReader +-- ** comicReader data ComicReaderView = Spread | Full deriving (Show, Eq) -comicReader :: ComicId -> Page -> Model -> View Action -comicReader _ _ model = case appComics model of +comicReader :: ComicId -> PageNumber -> Form -> View Move +comicReader _ _ form = case appComics form of NotAsked -> loading Loading -> loading Failure _ -> nocomics - Success comics -> case cpState model of + Success comics -> case cpState form of NotReading -> template "comic-player" [text "error: not reading"] - Cover id -> viewOr404 comics comicSpread id 1 model + Cover id -> viewOr404 comics comicSpread id 1 form ChooseExperience id pg -> - viewOr404 comics chooseExperiencePage id pg model - Reading Spread id pg -> viewOr404 comics comicSpread id pg model - Reading Full id pg -> viewOr404 comics zoomScreen id pg model - Watching id -> viewOr404 comics comicVideo id 0 model + viewOr404 comics chooseExperiencePage id pg form + Reading Spread id pg -> viewOr404 comics comicSpread id pg form + Reading Full id pg -> viewOr404 comics zoomScreen id pg form + Watching id -> viewOr404 comics comicVideo id 0 form -zoomScreen :: Comic -> Page -> Model -> View Action -zoomScreen comic page model = +zoomScreen :: Comic -> PageNumber -> Form -> View Move +zoomScreen comic page form = template "comic-player" [ topbar, @@ -681,7 +680,7 @@ zoomScreen comic page model = class_ "comic-page-full" ] ], - comicControls comic page model + comicControls comic page form ] where comicImg = @@ -691,23 +690,23 @@ zoomScreen comic page model = <> padLeft page <> ".png" --- * comicReaderSpread +-- ** comicReaderSpread type ComicReaderSpread = "comic" :> Api.Capture "id" ComicId - :> Api.Capture "page" Page - :> View Action + :> Api.Capture "page" PageNumber + :> View Move comicReaderSpreadProxy :: Proxy ComicReaderSpread comicReaderSpreadProxy = Proxy -comicReaderSpreadLink :: ComicId -> Page -> Api.URI +comicReaderSpreadLink :: ComicId -> PageNumber -> Api.URI comicReaderSpreadLink id page = linkURI $ Api.safeLink routes comicReaderSpreadProxy id page -comicSpread :: Comic -> Page -> Model -> View Action -comicSpread comic page model = +comicSpread :: Comic -> PageNumber -> Form -> View Move +comicSpread comic page form = template "comic-player" [ topbar, @@ -721,7 +720,7 @@ comicSpread comic page model = closeButton ], appmenu, - comicControls comic page model + comicControls comic page form ] where comicImgLeft, comicImgRight :: MisoString @@ -738,7 +737,7 @@ comicSpread comic page model = <> padLeft (1 + page) <> ".png" -closeButton :: View Action +closeButton :: View Move closeButton = a_ [id_ "close-button", onClick $ ChangeURI discoverLink] @@ -749,14 +748,14 @@ closeButton = type ComicReaderFull = "comic" :> Api.Capture "id" ComicId - :> Api.Capture "page" Page + :> Api.Capture "page" PageNumber :> "full" - :> View Action + :> View Move comicReaderFullProxy :: Proxy ComicReaderFull comicReaderFullProxy = Proxy -comicReaderFullLink :: ComicId -> Page -> Api.URI +comicReaderFullLink :: ComicId -> PageNumber -> Api.URI comicReaderFullLink id page = linkURI $ Api.safeLink routes comicReaderFullProxy id page @@ -765,14 +764,14 @@ comicReaderFullLink id page = type ComicVideo = "comic" :> Api.Capture "id" ComicId - :> Api.Capture "page" Page + :> Api.Capture "page" PageNumber :> "video" - :> View Action + :> View Move comicVideoProxy :: Proxy ComicVideo comicVideoProxy = Proxy -comicVideoLink :: ComicId -> Page -> Api.URI +comicVideoLink :: ComicId -> PageNumber -> Api.URI comicVideoLink id page = linkURI $ Api.safeLink routes comicVideoProxy id page @@ -782,7 +781,7 @@ frameborder_ = textProp "frameborder" allowfullscreen_ :: Bool -> Attribute action allowfullscreen_ = boolProp "allowfullscreen" -comicVideo :: Comic -> Page -> Model -> View Action +comicVideo :: Comic -> PageNumber -> Form -> View Move comicVideo _ _ _ = template "comic-player" @@ -807,12 +806,12 @@ comicVideo _ _ _ = maybeView :: (a -> View action) -> Maybe a -> View action maybeView = maybe (text "") -mediaInfo :: Maybe Comic -> User -> View Action +mediaInfo :: Maybe Comic -> User -> View Move mediaInfo Nothing _ = text "" mediaInfo (Just comic) user = div_ [class_ "media-info"] [info comic user] -appmenu :: View Action +appmenu :: View Move appmenu = aside_ [id_ "appmenu"] $ btn </ links where links = @@ -834,13 +833,13 @@ appmenu = aside_ [id_ "appmenu"] $ btn </ links -- TODO: make this a loading gif of some sort... maybe the hero icon filling -- from white to red -loading :: View Action +loading :: View Move loading = div_ [class_ "loading"] [text "Loading..."] -nocomics :: View Action +nocomics :: View Move nocomics = div_ [class_ "loading"] [text "error: no comics found"] -shelf :: IsMediaObject o => MisoString -> [o] -> View Action +shelf :: IsMediaObject o => MisoString -> [o] -> View Move shelf title comics = div_ [class_ "shelf"] @@ -850,17 +849,17 @@ shelf title comics = viewOr404 :: [Comic] -> - (Comic -> Page -> Model -> View Action) -> + (Comic -> PageNumber -> form -> View Move) -> ComicId -> - Page -> - Model -> - View Action -viewOr404 comics f id pg model = + PageNumber -> + form -> + View Move +viewOr404 comics f id pg form = case findComic id comics of - Just c -> f c pg model - Nothing -> the404 model + Just c -> f c pg form + Nothing -> the404 form -template :: MisoString -> [View Action] -> View Action +template :: MisoString -> [View Move] -> View Move template id = div_ [id_ id, class_ "app is-black"] padLeft :: Int -> MisoString @@ -868,8 +867,8 @@ padLeft n | n < 10 = ms ("0" <> Legacy.show n) | otherwise = ms $ Legacy.show n -comicControls :: Comic -> Page -> Model -> View Action -comicControls comic page model = +comicControls :: Comic -> PageNumber -> Form -> View Move +comicControls comic page form = footer_ [id_ "app-foot", class_ "comic-controls"] [ div_ @@ -879,7 +878,7 @@ comicControls comic page model = [ audio_ [id_ audioId, loop_ True, crossorigin_ "anonymous"] [source_ [src_ $ ms $ Pack.demo <> "stars-instrumental.mp3"]], - el $ PlayPause audioId $ cpAudioState model, + el $ PlayPause audioId $ cpAudioState form, span_ [css $ euro <> thicc <> smol <> wide] [text "Experiencing: Original"] @@ -892,8 +891,8 @@ comicControls comic page model = ], div_ [class_ "comic-controls-share"] - [ el $ SaveIcon comic $ user model, - el $ ZoomIcon (magnification model) comic page, + [ el $ SaveIcon comic $ user form, + el $ ZoomIcon (magnification form) comic page, button_ [class_ "button icon is-large", onClick ToggleFullscreen] [i_ [class_ "fa fa-expand"] []] @@ -904,7 +903,7 @@ comicControls comic page model = rightPage = ms . Legacy.show $ 1 + page totalpages = ms . Legacy.show $ comicPages comic -topbar :: View Action +topbar :: View Move topbar = header_ [id_ "app-head", class_ "is-black", css euro] @@ -930,12 +929,12 @@ topbar = ] ] -row :: [View Action] -> View Action +row :: [View Move] -> View Move row = div_ [css $ Clay.display Clay.flex <> Clay.flexDirection Clay.row] -column :: [View Action] -> View Action +column :: [View Move] -> View Move column = div_ [css $ Clay.display Clay.flex <> Clay.flexDirection Clay.column] -- | Links -the404 :: Model -> View Action +the404 :: form -> View Move the404 _ = template "404" [p_ [] [text "Not found"]] diff --git a/Hero/Host.hs b/Hero/Host.hs index 5341cc6..87b9d33 100644 --- a/Hero/Host.hs +++ b/Hero/Host.hs @@ -10,6 +10,8 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-orphan #-} + -- | Hero web app -- -- : exe mmc @@ -54,7 +56,6 @@ import qualified Clay import qualified Crypto.JOSE.JWK as Crypto import Data.Acid (AcidState) import qualified Data.Acid.Abstract as Acid -import qualified Data.Aeson as Aeson import Data.Text (Text) import qualified Data.Text.Lazy as Lazy import Hero.Core @@ -164,7 +165,7 @@ instance Envy.DefConfig Config where instance Envy.FromEnv Config -- | Convert client side routes into server-side web handlers -type AppHostRoutes = ToServerRoutes AppRoutes Templated Action +type AppHostRoutes = ToServerRoutes AppRoutes Templated Move -- | These are the main app handlers, and should require authentication. appHostHandlers :: User -> Server AppHostRoutes @@ -178,7 +179,7 @@ appHostHandlers _ = :<|> chooseExperienceHandler -- | Marketing pages -type PubHostRoutes = ToServerRoutes PubRoutes Templated Action +type PubHostRoutes = ToServerRoutes PubRoutes Templated Move pubHostHandlers :: Server PubHostRoutes pubHostHandlers = @@ -193,7 +194,7 @@ wrapAuth :: Auth.AuthResult user -> route wrapAuth f authResult = case authResult of - Auth.Authenticated user -> f user + Auth.Authenticated u -> f u Auth.BadPassword -> Auth.throwAll err401 Auth.NoSuchUser -> Auth.throwAll err406 Auth.Indefinite -> Auth.throwAll err422 @@ -355,7 +356,7 @@ handle404 _ respond = $ toHtml $ Templated $ the404 - $ initModel homeLink + $ initForm homeLink fontAwesomeRef :: MisoString fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css" @@ -371,31 +372,31 @@ bulmaRef :: MisoString bulmaRef = "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css" -homeHandler :: Handler (Templated (View Action)) -homeHandler = pure . Templated . home $ initModel homeLink +homeHandler :: Handler (Templated (View Move)) +homeHandler = pure . Templated . home $ initForm homeLink -comicCoverHandler :: ComicId -> Handler (Templated (View Action)) +comicCoverHandler :: ComicId -> Handler (Templated (View Move)) comicCoverHandler id = - pure . Templated . comicCover id . initModel $ comicLink id + pure . Templated . comicCover id . initForm $ comicLink id -comicPageHandler :: ComicId -> Page -> Handler (Templated (View Action)) +comicPageHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) comicPageHandler id n = - pure . Templated . comicReader id n . initModel $ comicReaderSpreadLink id n + pure . Templated . comicReader id n . initForm $ comicReaderSpreadLink id n -comicPageFullHandler :: ComicId -> Page -> Handler (Templated (View Action)) +comicPageFullHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) comicPageFullHandler id n = - pure . Templated . comicReader id n . initModel $ comicReaderFullLink id n + pure . Templated . comicReader id n . initForm $ comicReaderFullLink id n -comicVideoHandler :: ComicId -> Page -> Handler (Templated (View Action)) +comicVideoHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) comicVideoHandler id n = - pure . Templated . comicReader id n . initModel $ comicVideoLink id n + pure . Templated . comicReader id n . initForm $ comicVideoLink id n -discoverHandler :: Handler (Templated (View Action)) -discoverHandler = pure . Templated . discover $ initModel discoverLink +discoverHandler :: Handler (Templated (View Move)) +discoverHandler = pure . Templated . discover $ initForm discoverLink -chooseExperienceHandler :: ComicId -> Page -> Handler (Templated (View Action)) +chooseExperienceHandler :: ComicId -> PageNumber -> Handler (Templated (View Move)) chooseExperienceHandler id n = - pure . Templated . comicReader id n . initModel $ chooseExperienceLink id n + pure . Templated . comicReader id n . initForm $ chooseExperienceLink id n -loginHandler :: Handler (Templated (View Action)) -loginHandler = pure . Templated . login $ initModel loginLink +loginHandler :: Handler (Templated (View Move)) +loginHandler = pure . Templated . login $ initForm loginLink diff --git a/Hero/Node.hs b/Hero/Node.hs index 55bc4b0..9934fd3 100644 --- a/Hero/Node.hs +++ b/Hero/Node.hs @@ -26,13 +26,13 @@ import qualified Data.Set as Set import qualified GHC.Show as Legacy import GHCJS.Types (JSVal) import Hero.Core - ( Action (..), + ( Move (..), AudioState (..), Comic (..), ComicReaderState (..), ComicReaderView (..), LoginForm (..), - Model (..), + Form (..), User (..), audioId, chooseExperienceLink, @@ -41,7 +41,7 @@ import Hero.Core comicVideoLink, discoverLink, handlers, - initModel, + initForm, routes, the404, ) @@ -57,7 +57,7 @@ import Protolude -- | Entry point for a miso application main :: IO () -main = miso $ \currentURI -> App {model = initModel currentURI, ..} +main = miso $ \currentURI -> App {model = initForm currentURI, ..} where update = move view = see @@ -73,18 +73,18 @@ main = miso $ \currentURI -> App {model = initModel currentURI, ..} (∈) = Set.member -- | Keyboard navigation - maps keys to actions. -keynav :: Set Int -> Action +keynav :: Set Int -> Move keynav ks | 37 ∈ ks = PrevPage -- ← | 39 ∈ ks = NextPage -- → - | 191 ∈ ks = DumpModel -- ? + | 191 ∈ ks = Dumpform -- ? | 32 ∈ ks = ToggleAudio audioId -- SPC | otherwise = NoOp -see :: Model -> View Action -see model = - case runRoute routes handlers uri model of - Left _ -> the404 model +see :: Form -> View Move +see form = + case runRoute routes handlers uri form of + Left _ -> the404 form Right v -> v -- | Console-logging @@ -94,38 +94,38 @@ foreign import javascript unsafe "console.log($1);" foreign import javascript unsafe "$1.value" getValue :: JSVal -> IO MisoString --- | Updates model, optionally introduces side effects -move :: Action -> Model -> Effect Action Model -move NoOp model = noEff model -move DumpModel model = model <# do - jslog $ ms $ Legacy.show model +-- | Updates form, optionally introduces side effects +move :: Move -> Form -> Effect Move Form +move NoOp form = noEff form +move Dumpform form = form <# do + jslog $ ms $ Legacy.show form pure NoOp -move (SelectExperience comic) model = model {cpState = ChooseExperience (comicId comic) 1} +move (SelectExperience comic) form = form {cpState = ChooseExperience (comicId comic) 1} <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1 -move (StartReading comic) model = model {cpState = Reading Spread (comicId comic) 1} +move (StartReading comic) form = form {cpState = Reading Spread (comicId comic) 1} <# do pure $ ChangeURI $ comicReaderSpreadLink (comicId comic) 1 -move (StartWatching comic) model = model {cpState = Watching (comicId comic)} +move (StartWatching comic) form = form {cpState = Watching (comicId comic)} <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 -move NextPage model = case cpState model of +move NextPage form = case cpState form of Reading Spread id pg -> - model {cpState = Reading Spread id (pg + 2)} <# do + form {cpState = Reading Spread id (pg + 2)} <# do pure $ ChangeURI $ comicReaderSpreadLink id (pg + 2) Reading Full id pg -> - model {cpState = Reading Full id (pg + 1)} <# do + form {cpState = Reading Full id (pg + 1)} <# do pure $ ChangeURI $ comicReaderFullLink id (pg + 1) Cover id -> - model {cpState = Reading Spread id 1} <# do + form {cpState = Reading Spread id 1} <# do pure $ ChangeURI $ comicReaderSpreadLink id 1 - _ -> noEff model -move PrevPage model = case cpState model of + _ -> noEff form +move PrevPage form = case cpState form of Reading Spread id pg -> - model {cpState = Reading Spread id (pg -2)} <# do + form {cpState = Reading Spread id (pg -2)} <# do pure $ ChangeURI $ comicReaderSpreadLink id (pg -2) Reading Full id pg -> - model {cpState = Reading Full id (pg -1)} <# do + form {cpState = Reading Full id (pg -1)} <# do pure $ ChangeURI $ comicReaderFullLink id (pg -1) - Cover _ -> noEff model - _ -> noEff model + Cover _ -> noEff form + _ -> noEff form move (ToggleZoom c pg) m = m {cpState = newState} <# pure act where goto lnk = ChangeURI $ lnk (comicId c) pg @@ -134,52 +134,52 @@ move (ToggleZoom c pg) m = m {cpState = newState} <# pure act Reading Full _ _ -> (reading Spread, goto comicReaderSpreadLink) Reading Spread _ _ -> (reading Full, goto comicReaderFullLink) x -> (x, NoOp) -move (ToggleInLibrary c) model = model {user = newUser} <# pure NoOp +move (ToggleInLibrary c) form = form {user = newUser} <# pure NoOp where - newUser = (user model) {userLibrary = newLib} + newUser = (user form) {userLibrary = newLib} newLib - | c `elem` (userLibrary $ user model) = - Protolude.filter (/= c) $ userLibrary $ user model - | otherwise = c : (userLibrary $ user model) -move (HandleURI u) model = model {uri = u} <# pure NoOp -move (ChangeURI u) model = model <# do + | c `elem` (userLibrary $ user form) = + Protolude.filter (/= c) $ userLibrary $ user form + | otherwise = c : (userLibrary $ user form) +move (HandleURI u) form = form {uri = u} <# pure NoOp +move (ChangeURI u) form = form <# do pushURI u pure NoOp -move FetchComics model = model <# (SetComics <$> fetchComics) -move (SetComics cs) model = noEff model {appComics = cs} -move (ToggleAudio i) model = model {cpAudioState = newState} <# do +move FetchComics form = form <# (SetComics <$> fetchComics) +move (SetComics cs) form = noEff form {appComics = cs} +move (ToggleAudio i) form = form {cpAudioState = newState} <# do el <- Document.getElementById i toggle el pure NoOp where - (newState, toggle) = case cpAudioState model of + (newState, toggle) = case cpAudioState form of Playing -> (Paused, Audio.pause) Paused -> (Playing, Audio.play) -move ToggleFullscreen model = model {cpState = newState} <# do +move ToggleFullscreen form = form {cpState = newState} <# do el <- Document.querySelector "body" -- TODO: check Document.fullscreenEnabled -- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled _ <- toggle el pure NoOp where - (toggle, newState) = case cpState model of + (toggle, newState) = case cpState form of Reading Full c n -> (const Fullscreen.exit, Reading Full c n) Reading Spread c n -> (Fullscreen.request, Reading Spread c n) -- otherwise, do nothing: x -> (pure, x) -move (SetMediaInfo x) model = model {dMediaInfo = x} +move (SetMediaInfo x) form = form {dMediaInfo = x} <# case x of Just Comic {comicId = id} -> pure $ ScrollIntoView $ "comic-" <> ms id Nothing -> pure NoOp -move (ScrollIntoView id) model = model <# do +move (ScrollIntoView id) form = form <# do jslog $ ms $ Legacy.show id scrollIntoView id pure NoOp -move ValidateUserPassword model = +move ValidateUserPassword form = batchEff - model + form [doLogin, pure FetchComics, pure <| ChangeURI discoverLink] where doLogin = do diff --git a/Hero/Part.hs b/Hero/Part.hs index e69de29..fb34fff 100644 --- a/Hero/Part.hs +++ b/Hero/Part.hs @@ -0,0 +1,3 @@ +module Hero.Part () where + + |