{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language MultiWayIf #-}
module HBS2.Git.Web.Html.Root where

import HBS2.Git.DashBoard.Prelude
import HBS2.Git.DashBoard.Types
import HBS2.Git.DashBoard.State

import HBS2.Git.Data.Tx.Git
import HBS2.Git.Data.RepoHead

import Data.Text qualified as Text
import Lucid.Base
import Lucid.Html5 hiding (for_)
import Lucid.Htmx

import Text.Pandoc hiding (getPOSIXTime)
import System.FilePath
import Data.Word
import Data.Either
import Data.List (sortOn)

import Skylighting.Core qualified as Sky
import Skylighting qualified as Sky

import Streaming.Prelude qualified as S

rootPath :: [String] -> [String]
rootPath = ("/":)

path :: [String] -> Text
path = Text.pack . joinPath . rootPath

myCss :: Monad m => HtmlT m ()
myCss = do
  link_ [rel_ "stylesheet", href_ (path ["css/custom.css"])]

hyper_ :: Text -> Attribute
hyper_  = makeAttribute "_"

onClickCopy :: Text -> Attribute
onClickCopy s =
  hyper_ [qc|on click writeText('{s}') into the navigator's clipboard add .clicked to me wait 2s remove .clicked from me|]

markdownToHtml :: Text -> Either PandocError String
markdownToHtml markdown = runPure $ do
  doc <- readMarkdown def {readerExtensions = pandocExtensions} markdown
  html <- writeHtml5String def {writerExtensions = pandocExtensions} doc
  return $ Text.unpack html

renderMarkdown' :: Text -> Text
renderMarkdown' markdown = case markdownToHtml markdown of
    Left{} -> markdown
    Right html -> Text.pack html

renderMarkdown :: Text -> Html ()
renderMarkdown markdown = case markdownToHtml markdown of
    Left{} -> blockquote_ (toHtml markdown)
    Right html -> toHtmlRaw $ Text.pack html

instance ToHtml RepoBrief where
  toHtml (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt)
  toHtmlRaw (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt)

data WithTime a = WithTime Integer a

instance ToHtml (WithTime RepoListItem) where
  toHtmlRaw = pure mempty

  toHtml (WithTime t it@RepoListItem{..}) = do

    let now = t

    let locked = isJust $ coerce @_ @(Maybe HashRef) rlRepoGK0

    let url = path ["repo", Text.unpack $ view rlRepoLwwAsText it]
    let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq

    let updated = "" <+> d
          where
            sec = now - t
            d | sec > 86400  = pretty (sec `div` 86400)  <+> "days ago"
              | sec > 3600   = pretty (sec `div` 3600)   <+> "hours ago"
              | otherwise    = pretty (sec `div` 60)     <+> "minutes ago"

    div_ [class_ "repo-list-item"] do
      div_ [class_ "repo-info", style_ "flex: 1; flex-basis: 70%;"] do

        h2_ [class_ "xclip", onClickCopy (view rlRepoLwwAsText it)] $ toHtml rlRepoName
        p_ $ a_ [href_ url] (toHtml $ view rlRepoLwwAsText it)

        toHtml rlRepoBrief

      div_ [ ] do
        div_ [ class_ "attr" ] do
          div_ [ class_ "attrname"]  (toHtml $ show updated)

        when locked do
          div_ [ class_ "attr" ] do
            div_ [ class_ "attrval icon"] do
              img_ [src_ "/icon/lock-closed.svg"]

rootPage :: Monad m => HtmlT m () -> HtmlT m ()
rootPage content  = do
  doctypehtml_ do
    head_ do
      meta_ [charset_ "UTF-8"]
      meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
      -- FIXME: static-local-loading
      link_ [rel_ "stylesheet", href_ "https://cdn.jsdelivr.net/npm/@picocss/pico@2.0.6/css/pico.min.css"]
      script_ [src_ "https://unpkg.com/hyperscript.org@0.9.12"] ""
      script_ [src_ "https://unpkg.com/htmx.org@1.9.11"] ""
      myCss

    body_ do
      header_ do
        div_ [class_ "header-title"] $ h1_ [] $ a_ [href_ "/"] "hbs2-peer dashboard"
      content



dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m ()
dashboardRootPage = rootPage do

  items <- lift $ selectRepoList mempty

  now  <- liftIO getPOSIXTime <&> fromIntegral . round

  div_ [class_ "container main"] $ do
    nav_ [class_ "left"] $ do
      div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"
      div_ [class_ "info-block"] "Всякая разная рандомная информация хрен знает, что тут пока выводить"

    main_ do

      section_ do
        h1_ "Git repositories"
        form_ [class_ "search"] do
            input_ [type_ "search", id_ "search"]
            button_ [class_ "search"] mempty


      section_ [id_ "repo-search-results"] do

        for_ items $ \item@RepoListItem{..} -> do
          toHtml (WithTime now item)



tabClick :: Attribute
tabClick =
  hyper_ "on click take .active from .tab for event's target"

-- repoMenu :: Monad m => HtmlT m () -> HtmlT m ()
repoMenu :: Term [Attribute] (t1 -> t2) => t1 -> t2
repoMenu = ul_ []


repoMenuItem0 :: Term [Attribute] (t1 -> t2) => [Attribute] -> t1 -> t2
repoMenuItem0 misc name = li_ ([class_  "tab active"] <> misc <> [tabClick]) name

repoMenuItem :: Term [Attribute] (t1 -> t2) => [Attribute] -> t1 -> t2
repoMenuItem misc name = li_ ([class_  "tab"] <> misc <> [tabClick]) name


parsedManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem  -> m ([Syntax C], Text)
parsedManifest RepoListItem{..} = do

  sto <- asks _sto
  mhead <- readRepoHeadFromTx sto (coerce rlRepoTx)

  let rawManifest  = (_repoManifest . snd =<< mhead)
                      & fromMaybe (coerce rlRepoBrief)
                      & Text.lines

  w <- S.toList_ do
         flip fix rawManifest $ \next ss -> do
          case ss of
            ( "" : rest )  -> S.yield (Right (Text.stripStart (Text.unlines rest)))
            ( a : rest )   -> S.yield (Left a ) >> next rest
            [] -> pure ()

  let meta = Text.unlines (lefts w)
                & Text.unpack
                & parseTop
                & fromRight mempty

  let manifest = mconcat $ rights  w

  pure (meta, manifest)


thisRepoManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m ()
thisRepoManifest it@RepoListItem{..} = do
  (_, manifest) <- lift $ parsedManifest it
  toHtmlRaw (renderMarkdown' manifest)

repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m)
         => LWWRefKey 'HBS2Basic
         -> [(GitRef, GitHash)]
         -> HtmlT m ()
repoRefs lww refs = do
  table_ [] do
    for_ refs $ \(r,h) -> do
      let r_ = Text.pack $ show $ pretty r
      let co = show $ pretty h
      let uri = path [ "repo", show $ pretty lww, "tree", co, co ]
      tr_ do
        td_ do

          if | Text.isPrefixOf "refs/heads" r_ -> do
                img_ [src_ "/icon/git-branch.svg"]
             | Text.isPrefixOf "refs/tags" r_ -> do
                img_ [src_ "/icon/git-tag.svg"]
             | otherwise -> mempty

        td_ (toHtml r_)
        td_ [class_ "mono"] $ a_ [ href_ "#"
                                 , hxGet_ uri
                                 , hxTarget_ "#repo-tab-data"
                                 ] (toHtml $ show $ pretty h)


showRefsHtmxAttribs :: String -> [Attribute]
showRefsHtmxAttribs repo =
  [ hxGet_ (path ["repo", repo, "refs"])
  , hxTarget_ "#repo-tab-data"
  ]

repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
         => LWWRefKey 'HBS2Basic
         -> GitHash -- ^ this
         -> GitHash -- ^ this
         -> [(GitObjectType, GitHash, Text)]
         -> Maybe GitHash -- ^ back
         -> HtmlT m ()

repoTree lww co root tree back' = do

  let repo = show $ pretty $ lww

  let syntaxMap = Sky.defaultSyntaxMap

  let co_ = show $ pretty co

  let sorted = sortOn (\(tp, _, name) -> (tpOrder tp, name)) tree
        where
          tpOrder Tree = (0 :: Int)
          tpOrder Blob = 1
          tpOrder _    = 2

  locator <- lift $ selectTreeLocator (TreeCommit co) (TreeTree root)

  let prefixSlash x = if fromIntegral x > 1 then span_ "/" else ""
  let showRoot =
        [ hxGet_ (path ["repo", repo, "tree", co_, co_])
        , hxTarget_ "#repo-tab-data"
        , href_ "#"
        ]

  table_ [] do

    tr_ do
      td_ [class_ "tree-locator", colspan_ "3"] do
        span_ [] $ a_ (showRefsHtmxAttribs repo <> [href_ "#" ]) $ toHtml (take 10 repo <> "..")
        span_ [] "/"
        span_ [] $ a_ showRoot $ toHtml (take 10 co_ <> "..")
        span_ [] "/"
        for_ locator $ \(_,this,level,name) -> do
          prefixSlash level
          let uri = path [ "repo", show $ pretty lww, "tree", co_, show (pretty this) ]
          span_ [] do
            a_ [ href_ "#"
               , hxGet_ uri
               , hxTarget_ "#repo-tab-data"
               ] (toHtml (show $ pretty name))

    tr_ mempty do

      for_ back' $ \root -> do
        let rootLink = path [ "repo", show $ pretty lww, "tree", co_, show (pretty root) ]
        td_ $ img_ [src_ "/icon/tree-up.svg"]
        td_ ".."
        td_ do a_ [ href_ "#"
                  , hxGet_ rootLink
                  , hxTarget_ "#repo-tab-data"
                  ] (toHtml $ show $ pretty root)

    for_ sorted $ \(tp,h,name) -> do
      let itemClass = pretty tp & show & Text.pack
      let hash_ = show $ pretty h
      let uri = path [ "repo", show $ pretty lww, "tree", co_, hash_ ]
      tr_ mempty do
        td_  $ case tp of
          Commit -> mempty
          Tree   -> img_ [src_ "/icon/tree.svg"]
          Blob   -> do
            let syn = Sky.syntaxesByFilename syntaxMap (Text.unpack name)
                        & headMay
                        <&> Text.toLower . Sky.sName

            let icon = case syn of
                         Just "haskell"    -> [src_ "/icon/haskell.svg"]
                         Just "markdown"   -> [src_ "/icon/markdown.svg"]
                         Just "nix"        -> [src_ "/icon/nixos.svg"]
                         Just "bash"       -> [src_ "/icon/terminal.svg"]
                         Just "python"     -> [src_ "/icon/python.svg"]
                         Just "javascript" -> [src_ "/icon/javascript.svg"]
                         Just "sql"        -> [src_ "/icon/sql.svg"]
                         Just s | s `elem` ["cabal","makefile","toml","ini","yaml"]
                                           -> [src_ "/icon/gear.svg"]
                         _                 -> [src_ "/icon/blob-filled.svg"]

            img_ ([alt_ (fromMaybe "blob" syn)] <> icon)

        td_ [class_ itemClass] (toHtml $ show $ pretty name)
        td_ [class_ "mono"] do
          case tp of
            Blob -> do
              span_ do
                toHtml $ show $ pretty h

            Tree -> do
              a_ [ href_ "#"
                 , hxGet_ uri
                 , hxTarget_ "#repo-tab-data"
                 -- , hxPushUrl_ "true"
                 ] (toHtml $ show $ pretty h)

            _ -> mempty


repoPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m ()
repoPage it@RepoListItem{..} = rootPage do

  let repo = show $ pretty rlRepoLww

  sto <- asks _sto
  mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx)

  (meta, manifest) <- lift $ parsedManifest it

  debug $ yellow "HEAD" <+> pretty rlRepoTx
  debug $ yellow "META" <+> pretty meta

  let author = headMay [ s | ListVal [ SymbolVal "author:", LitStrVal s ] <- meta ]
  let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ]


  div_ [class_ "container main"] $ do
    nav_ [class_ "left"] $ do

      div_ [class_ "info-block" ] do
        for_ author $ \a -> do
            div_ [ class_ "attr" ] do
              div_ [ class_ "attrname"] "author:"
              div_ [ class_ "attrval"] $ toHtml a

        for_ public $ \p -> do
            div_ [ class_ "attr" ] do
              div_ [ class_ "attrname"] "public:"
              div_ [ class_ "attrval"] $ toHtml p

      div_ [class_ "info-block" ] do
        for_ (snd <$> mhead) $ \rh -> do
          h6_ [] "heads"
          for_ (view repoHeadHeads rh) $ \branch -> do
            div_ [ class_ "attrval onleft"] $ toHtml branch

      div_ [class_ "info-block" ] do
        for_ (snd <$> mhead) $ \rh -> do
          h6_ [] "tags"
          for_ (view repoHeadTags rh) $ \tag -> do
            div_ [ class_ "attrval onleft"] $ toHtml tag

    main_ do

      nav_ [ role_ "tab-control" ] do
       repoMenu do
        repoMenuItem  mempty $ a_ [href_ "/"] "root"

        repoMenuItem0 [ hxGet_ (path ["repo", repo, "manifest"])
                      , hxTarget_ "#repo-tab-data"
                      ] "manifest"

        repoMenuItem  [
                      ] "commits"

        repoMenuItem (showRefsHtmxAttribs repo) "tree"

      section_ [id_ "repo-data"] do
        h1_ (toHtml $ rlRepoName)

      div_ [id_ "repo-tab-data"] do
        toHtmlRaw (renderMarkdown' manifest)