module Main where #ifndef ghcjs_HOST_OS import Language.Javascript.JSaddle.Warp as JSaddle #endif import Api import Data.Bifunctor import Data.Default import Data.Function import Miso import Miso.String (toMisoString) import NeatInterpolation qualified as Q import Page (Page, initialPage, updatePage, viewPage) import Page qualified as Page import Route (parseURI) import Version data Model = Loading | Failed String | Loaded LoadedState deriving (Show, Eq) data LoadedState = LoadedState { collections :: [String], schemaVersion :: Version, page :: Maybe (Either String Page) } deriving (Show, Eq) instance Default Model where def = Loading data Action = -- Loading SetLoaded (Either String LoadedState) | -- Loaded NoOp | Init URI | HandleURI URI | HandlePage Page.Action | SetPage (Either String Page) deriving (Show, Eq) #ifndef ghcjs_HOST_OS runApp :: JSM () -> IO () runApp f = JSaddle.debugOr 8080 (f >> syncPoint) JSaddle.jsaddleApp #else runApp :: IO () -> IO () runApp app = app #endif main :: IO () main = runApp $ do uri <- getCurrentURI startApp App {initialAction = Init uri, ..} where model = def update = updateModel view = viewModel events = defaultEvents subs = [uriSub HandleURI] mountPoint = Nothing logLevel = Off updateModel :: Action -> Model -> Effect Action Model updateModel _ (Failed err) = noEff (Failed err) updateModel (Init uri) Loading = Loading <# do page <- Just <$> initialPage (parseURI uri) schemaVersion' <- fetchSchemaVersion collections' <- fetchCollections pure $ SetLoaded do schemaVersion <- schemaVersion' collections <- collections' pure LoadedState {..} updateModel (Init _) m = noEff m updateModel (SetLoaded (Left err)) Loading = noEff (Failed err) updateModel (SetLoaded (Right state)) Loading = noEff (Loaded state) updateModel (SetLoaded _) m = noEff m updateModel _ Loading = noEff Loading updateModel NoOp (Loaded s) = noEff (Loaded s) updateModel (HandleURI uri) (Loaded s) = Loaded s <# do let route = parseURI uri SetPage <$> initialPage route updateModel (SetPage page) (Loaded s) = noEff (Loaded s {page = Just page}) updateModel (HandlePage action) (Loaded s) = case s.page of Just (Right page) -> fmap Loaded $ updatePage action page & bimap HandlePage (\page -> s {page = Just (Right page)}) _ -> noEff (Loaded s) viewModel :: Model -> View Action viewModel Loading = text ".." viewModel (Failed s) = err s viewModel (Loaded s) = div_ [] $ [ viewCss, viewHeader s, nav_ [] [viewCollections s], main_ [] $ [ HandlePage <$> maybe (text "..") (either err viewPage) s.page ] ] viewCss :: View Action viewCss = node HTML "style" Nothing [type_ "text/css"] [ text ( toMisoString [Q.text| /* normalize */ * { box-sizing: border-box; } body { margin: 0; min-height: 100vh; } /* typography */ html { font: Iosevka; } /* layout */ body > div { display: flex; flex-flow: row nowrap; min-height: 100vh; padding-top: 64px; align-items: stretch; } header { position: fixed; top: 0; left: 0; width: 100%; height: 64px; } nav, main { min-height: 100%; } nav { flex: 0 0 200px; } main { flex: 1 1 auto; } /* borders */ header { border-bottom: 1px solid gray; } nav { border-right: 1px solid gray; } /* padding */ nav, header, main { padding: 16px; } /* scrolling */ body > div { overflow: visible; } header { overflow: visible; } nav, main { overflow: auto; } /* header */ header { display: flex; align-items: center; } header section { margin-left: auto; } header section:first-child { margin-left: 0; } /* table layout */ th, td { text-align: left; padding: 0 16px; line-height: 52px; text-overflow: ellipsis; } /* table borders */ table { border-collapse: collapse; border-left: 1px solid gray; border-right: 1px solid gray; } th, td { border-top: 1px solid gray; border-bottom: 1px solid gray; } |] ) ] err :: String -> View action err = text . toMisoString . ("err! " <>) viewHeader :: LoadedState -> View Action viewHeader s = header_ [] $ [ section_ [] [h1_ [] [a_ [href_ "#"] [text "acms"]]], section_ [] (viewBranch s) ] viewBranch :: LoadedState -> [View Action] viewBranch s = [ text (toMisoString (versionToString s.schemaVersion)), text " ", select_ [] [option_ [] [text "main"]] ] viewCollections :: LoadedState -> View Action viewCollections s = section_ [] $ [ span_ [] [text "collections"], ol_ [] $ [ li_ [] [ a_ [href_ (toMisoString ("#collection/" <> collection))] [text (toMisoString collection)] ] | collection <- s.collections ] ]