{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

-- the ToHtml class also provides a method without escaping which we don't use,
-- so it's safe to never define it
{-# OPTIONS_GHC -Wno-missing-methods #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Module containing orphan instances of Lucid's ToHtml, used for rendering
-- linter results as html
module Orphans () where


import           CheckDir        (DirResult (..), MissingAsset (MissingAsset),
                                  MissingDep (..), maximumLintLevel)
import           CheckMap        (MapResult (..))
import           Control.Monad   (forM_, unless)
import           Data.Functor    ((<&>))
import           Data.List       (intersperse)
import           Data.List.Extra (escapeJSON)
import qualified Data.Map        as M
import           Data.Text       (Text)
import qualified Data.Text       as T
import           Lucid           (HtmlT, ToHtml)
import           Lucid.Base      (ToHtml (toHtml))
import           Lucid.Html5     (class_, code_, div_, h2_, h3_, h4_, h5_, id_,
                                  li_, p_, script_, span_, src_, ul_)
import           Text.Dot        (showDot)
import           Types           (Hint (Hint), Level (..))



badge :: Monad m => Level -> HtmlT m () -> HtmlT m ()
badge level = span_ [class_ badgetype]
    where badgetype = case level of
            Info       -> "badge badge-info"
            Suggestion -> "badge badge-info"
            Warning    -> "badge badge-warning"
            Forbidden  -> "badge badge-danger"
            Error      -> "badge badge-danger"
            Fatal      -> "badge badge-danger"

-- | Lint Levels directly render into badges
instance ToHtml Level where
  toHtml level = badge level (toHtml $ show level)

-- | Hints are just text with a level
instance ToHtml Hint where
  toHtml (Hint level msg) = do
    toHtml level; " "; toHtml msg


headerText :: Monad m => Level -> HtmlT m ()
headerText = \case
  Info  -> "Couldn't find a thing to complain about. Congratulations!"
  Suggestion -> "There's a couple smaller nitpicks; maybe take a look at those?"
  Warning -> "The map is fine, but some things look like they might be mistakes; \
             \perhaps you want to take a look at those?"
  Forbidden -> "The map is fine in principle, but contains things that are not\
               \allowed at this event"
  Error -> "Your map currently contains errors and should probably be fixed"
  Fatal -> "Something broke while linting; if you're not sure why or how to make \
           \it work, feel free to tell an admin about it"


-- | The fully monky
instance ToHtml DirResult where
  toHtml res@DirResult { .. } = do

    p_ $ do badge maxlevel "Linted:"; " "; headerText maxlevel

    h2_ "Exits"
    unless (null dirresultDeps) $ ul_ $
      forM_ dirresultDeps $ \missing -> do
        li_ $ do
          -- TODO: the whole Maybe Bool thing is annoying; I think that was a
          -- remnant of talking to python stuff and can probably be removed?
          if depFatal missing == Just True
            then do { toHtml Error; "Map " }
            else do { toHtml Warning; "Entrypoint " }
          code_ $ toHtml (entrypoint missing)
          " does not exist"
          unless (depFatal missing /= Just True) $ do
            " (no layer with that name is a "; mono "startLayer"; ")"
          ", but is used as "; mono "exitUrl"; " in "
          placeList (neededBy missing); "."

    -- the exit graph thing
    script_ [ src_ "/dot-wasm.js" ] (""::Text)
    script_ [ src_ "/d3.js" ] (""::Text)
    script_ [ src_ "/d3-graphviz.js" ] (""::Text)
    div_ [ id_ "exitGraph" ] ""
    script_ $
      "\
      \d3.select(\"#exitGraph\")\n\
      \  .graphviz()\n\
      \  .dot(\"" <> T.pack (escapeJSON $ showDot dirresultGraph) <> "\")\n\
      \  .render()\n\
      \"

    unless (null dirresultMissingAssets) $ do
      h2_ [class_ "border-bottom"] "Assets"
      ul_ $ forM_ dirresultMissingAssets $
        \(MissingAsset MissingDep { .. }) -> li_ $ do
          toHtml Error; "File "; mono $ toHtml entrypoint
          " does not exist, but is referenced in "; placeList neededBy; ")"

    unless (null dirresultMaps) $ do
      h3_ "Maps"
      flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do
        h4_ (toHtml name)
        forM_ mapresultGeneral $ \lint ->
          li_ (toHtml lint)
        h5_ "Layers"
        ul_ (listMapWithKey mapresultLayer)
        h5_ "Tilesets"
        ul_ (listMapWithKey mapresultTileset)

    where
      maxlevel = maximumLintLevel res

      mono text = code_ [class_ "small text-muted"] text

      placeList :: (Monad m, ToHtml a) => [a] -> HtmlT m ()
      placeList occurances =
        sequence_ . intersperse ", " $ occurances <&> \place ->
          code_ [class_ "small text-muted"] (toHtml place)

      listMapWithKey map =
        flip M.foldMapWithKey map $ \lint places ->
          li_ $ do toHtml lint; " (in "; placeList places; ")"