acms/frontend/app/Main.hs

module Main where

#ifndef ghcjs_HOST_OS
import Language.Javascript.JSaddle.Warp as JSaddle
#endif

import Data.Bifunctor
import Data.Default
import Data.Function
import GHC.Generics (Generic)
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)

data Model = Model
  { page :: Maybe (Either String Page)
  }
  deriving (Show, Eq, Generic, Default)

data Action
  = 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 NoOp m = noEff m
updateModel (Init uri) m =
  m <# do
    SetPage <$> initialPage (parseURI uri)
updateModel (HandleURI uri) m =
  m <# do
    let route = parseURI uri
    SetPage <$> initialPage route
updateModel (SetPage page) m = noEff m {page = Just page}
updateModel (HandlePage action) m =
  case m.page of
    Just (Right page) ->
      updatePage action page
        & bimap HandlePage (\page -> m {page = Just (Right page)})
    _ -> noEff m

viewModel :: Model -> View Action
viewModel model =
  div_ [] $
    [ viewCss,
      viewHeader,
      nav_ [] [viewCollections],
      main_ [] $
        [ HandlePage
            <$> maybe
              (text "..")
              (either err viewPage)
              model.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 :: View Action
viewHeader =
  header_ [] $
    [ section_ [] [h1_ [] [a_ [href_ "#"] [text "acms"]]],
      section_ [] [viewBranch]
    ]

viewBranch :: View Action
viewBranch =
  select_ [] [option_ [] [text "main"]]

viewCollections :: View Action
viewCollections =
  section_ [] $
    [ span_ [] [text "collections"],
      ol_ [] $
        [ li_ [] [a_ [href_ "#collection/posts"] [text "posts"]],
          li_ [] [a_ [href_ "#collection/posts1"] [text "posts1"]]
        ]
    ]