diff options
author | Ben Sima <ben@bsima.me> | 2020-02-15 23:03:40 -0800 |
---|---|---|
committer | Ben Sima <ben@bsima.me> | 2020-02-16 00:37:52 -0800 |
commit | d480cce48d04d5e4353281f014f66fd61301c393 (patch) | |
tree | 395e1ed88036a9511f2197cce885c1a8a2256d64 /Com/MusicMeetsComics/Aero.hs | |
parent | 9c01b1fc7dac01b5d2a53ffc710c24811a773904 (diff) |
Split buildHaskellApp into buildGhc and buildGhcjs
Two functions makes it simpler to reason about what is being built and
when, even if it is a bit more explicit. I also removed the dumb
Apex/Aero naming thing because Server/Client is just easier to remember.
Diffstat (limited to 'Com/MusicMeetsComics/Aero.hs')
-rw-r--r-- | Com/MusicMeetsComics/Aero.hs | 174 |
1 files changed, 0 insertions, 174 deletions
diff --git a/Com/MusicMeetsComics/Aero.hs b/Com/MusicMeetsComics/Aero.hs deleted file mode 100644 index 26d8aaf..0000000 --- a/Com/MusicMeetsComics/Aero.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Com.MusicMeetsComics.Aero where - -import Com.MusicMeetsComics.App ( Action(..) - , Comic(..) - , ComicReaderState(..) - , ComicReaderView(..) - , Model(..) - , AudioState(..) - , audioId - , chooseExperienceLink - , comicPlayerSpreadLink - , comicPlayerFullLink - , comicVideoLink - , handlers - , initModel - , the404 - , routes - ) -import qualified Com.Simatime.Network as Network -import Data.Aeson ( eitherDecodeStrict ) -import qualified Data.Set as Set -import qualified GHC.Show as Legacy -import JavaScript.Web.XMLHttpRequest ( Request(..) - , Method(GET) - , RequestData(NoData) - , contents - , xhrByteString - ) -import Miso -import Miso.Effect.DOM (scrollIntoView) -import qualified Miso.FFI.Audio as Audio -import qualified Miso.FFI.Document as Document -import qualified Miso.FFI.Fullscreen as Fullscreen -import Miso.String -import Protolude - --- | Entry point for a miso application -main :: IO () -main = miso $ \currentURI -> App { model = initModel currentURI, .. } - where - update = move - view = see - subs = [ uriSub HandleURI - , keyboardSub keynav - ] - events = defaultEvents - initialAction = FetchComics - mountPoint = Nothing - -(∈) :: Ord a => a -> Set a -> Bool -(∈) = Set.member - --- | Keyboard navigation - maps keys to actions. -keynav :: Set Int -> Action -keynav ks - | 37 ∈ ks = PrevPage -- ^ left arrow - | 39 ∈ ks = NextPage -- ^ right arrow - | 191 ∈ ks = DumpModel -- ^ ? - | 32 ∈ ks = ToggleAudio audioId -- ^ SPC - | otherwise = NoOp - -see :: Model -> View Action -see model = - case runRoute routes handlers uri model of - Left _ -> the404 model - Right v -> v - --- | Console-logging -foreign import javascript unsafe "console.log($1);" - say :: MisoString -> IO () - --- | Updates model, optionally introduces side effects -move :: Action -> Model -> Effect Action Model -move NoOp model = noEff model -move DumpModel model = model <# do - say $ ms $ Legacy.show model - pure NoOp -move (SelectExperience comic) model = model { cpState = ChooseExperience (comicId comic) 1 } - <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1 -move (StartReading comic) model = model { cpState = Reading Spread (comicId comic) 1 } - <# do pure $ ChangeURI $ comicPlayerSpreadLink (comicId comic) 1 -move (StartWatching comic) model = model { cpState = Watching (comicId comic) } - <# do pure $ ChangeURI $ comicVideoLink (comicId comic) 1 -move NextPage model = case cpState model of - Reading Spread id pg -> - model { cpState = Reading Spread id (pg+2) } <# do - pure $ ChangeURI $ comicPlayerSpreadLink id (pg+2) - Reading Full id pg -> - model { cpState = Reading Full id (pg+1) } <# do - pure $ ChangeURI $ comicPlayerFullLink id (pg+1) - Cover id -> - model { cpState = Reading Spread id 1 } <# do - pure $ ChangeURI $ comicPlayerSpreadLink id 1 - _ -> noEff model -move PrevPage model = case cpState model of - Reading Spread id pg -> - model { cpState = Reading Spread id (pg-2) } <# do - pure $ ChangeURI $ comicPlayerSpreadLink id (pg-2) - Reading Full id pg -> - model { cpState = Reading Full id (pg-1) } <# do - pure $ ChangeURI $ comicPlayerFullLink id (pg-1) - Cover _ -> noEff model - _ -> noEff model -move (ToggleZoom c pg) m = m { cpState = newState } <# do pure act - where - goto lnk = ChangeURI $ lnk (comicId c) pg - reading v = Reading v (comicId c) pg - (newState, act) = case cpState m of - Reading Full _ _ -> (reading Spread, goto comicPlayerSpreadLink) - Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink) - x -> (x, NoOp) -move (ToggleInLibrary c) model = model { userLibrary = newLib } <# pure NoOp - where - newLib | c `elem` (userLibrary model) = - Protolude.filter (/= c) $ userLibrary model - | otherwise = c : (userLibrary model) -move (HandleURI u) model = model { uri = u } <# pure NoOp -move (ChangeURI u) model = model <# 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 - el <- Document.getElementById i - toggle el - pure NoOp - where - (newState, toggle) = case cpAudioState model of - Playing -> (Paused, Audio.pause) - Paused -> (Playing, Audio.play) -move ToggleFullscreen model = model { 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 - 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 } <# do - case x of - Just Comic {comicId = id} -> - pure $ ScrollIntoView $ "comic-" <> ms id - Nothing -> - pure NoOp -move (ScrollIntoView id) model = model <# do - say $ ms $ Legacy.show id - scrollIntoView id - pure NoOp - -fetchComics :: IO (Network.RemoteData MisoString [Comic]) -fetchComics = do - mjson <- contents <$> xhrByteString req - case mjson of - Nothing -> - pure $ Network.Failure "Could not fetch comics from server." - Just json -> pure $ Network.fromEither - $ either (Left . ms) pure - $ eitherDecodeStrict json - where - req = Request - { reqMethod = GET - , reqURI = "/api/comic" -- FIXME: can we replace this hardcoding? - , reqLogin = Nothing - , reqHeaders = [] - , reqWithCredentials = False - , reqData = NoData - } |