{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Literate.Document.HTML (
  module Literate.Document.HTML,
  module Text.Blaze.Html5,
  module Text.Blaze.Renderer.Utf8,
)
where

import Data.Char qualified as Char
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.String qualified as String
import Data.Text qualified as Text
import Data.Text.Short qualified as ShortText
import Data.Time.Format.ISO8601 qualified as Time
import Data.Time.LocalTime qualified as Time
import Literate.Document qualified as Doc
import Literate.Document.Table
import Literate.Document.Type hiding (classes)
import Literate.Prelude
import System.FilePath.Posix ((</>))
import Text.Blaze
import Text.Blaze.Html5
import Text.Blaze.Html5.Attributes qualified as HA
import Text.Blaze.Internal (MarkupM (Parent))
import Text.Blaze.Renderer.Utf8
import Text.Printf qualified as Printf

instance IsString AttributeValue
instance IsString Html

classes :: [Class] -> (Bool, Attribute)
classes cls =
  ( not $ null clsFiltered
  , HA.class_ $ clsFiltered <&> toValue & List.intersperse " " & mconcat
  )
  where
    clsFiltered = cls & List.filter (not . Text.null . Doc.unClass)

className :: Show a => a -> String
className x =
  x & show & List.map \c ->
    if Char.isAlphaNum c
      then c
      else '-'

type CSSBlock = Map String String

styles :: CSSBlock -> (Bool, Attribute)
styles kvs =
  ( styFiltered & null & not
  , HA.style $
      mconcat
        [ toValue k <> ":" <> toValue v <> ";"
        | (k, v) <- styFiltered
        ]
  )
  where
    styFiltered = kvs & Map.toList & List.filter \(_k, v) -> v & null & not

type CSS = Map [String] CSSBlock
styleCSS :: CSS -> Markup
styleCSS m =
  style
    ! HA.type_ "text/css"
    $ [ mconcat [n <> " {" | n <- ns]
          <> "\n"
          <> List.unlines
            [ k <> ":" <> v <> ";"
            | (k, v) <- kvs & Map.toList
            , not (null v)
            ]
          <> mconcat [" }" | _n <- ns]
          <> "\n"
      | (ns, kvs) <- m & Map.toList
      , kvs & null & not
      ]
      & List.unlines
      & toMarkup

class ToCSS a where
  toCSS :: a -> String

instance ToMarkup ShortText where
  toMarkup = ShortText.toText >>> toMarkup
  preEscapedToMarkup = ShortText.toText >>> preEscapedToMarkup
instance ToCSS a => ToCSS (Maybe a) where
  toCSS = maybe "" toCSS
instance ToCSS Text where
  toCSS = Text.unpack
instance ToCSS Length where
  toCSS = \case
    LengthAbsolute x -> x & toCSS
    LengthRelative x -> x & toCSS
instance ToCSS LengthAbsolute where
  toCSS = \case
    LengthAbsoluteMillimeters x -> show x <> "mm"
instance ToCSS LengthRelative where
  toCSS = \case
    LengthRelativeFractionalRatio x -> show x <> "fr"
    LengthRelativeMaxContent -> "max-content"
    LengthRelativeMinContent -> "min-content"
instance ToCSS PageSize where
  toCSS = \case
    PageSizeA5 -> "A5"
    PageSizeA4 -> "A4"
    PageSizeA4Plus -> "A4plus"
    PageSizeA3 -> "A3"
instance ToCSS PageOrientation where
  toCSS = \case
    PageOrientationPortrait -> "portrait"
    PageOrientationLandscape -> "landscape"
instance ToCSS Justify where
  toCSS = \case
    JustifyCenter -> "center"
    JustifyEnd -> "end"
    JustifySpaceAround -> "space-around"
    JustifySpaceBetween -> "space-between"
    JustifySpaceEvenly -> "space-evenly"
    JustifyStart -> "start"
instance ToCSS Align where
  toCSS = \case
    AlignBaseline -> "baseline"
    AlignBaselineFirst -> "first-baseline"
    AlignBaselineLast -> "last-baseline"
    AlignCenter -> "center"
    AlignEnd -> "end"
    AlignSpaceAround -> "space-around"
    AlignSpaceBetween -> "space-between"
    AlignSpaceEvenly -> "space-evenly"
    AlignStart -> "start"
    AlignStretch -> "stretch"
instance ToCSS FlexDirection where
  toCSS = \case
    FlexDirectionColumn -> "column"
    FlexDirectionRow -> "row"

cssPageWidth = \case
  PageOrientationLandscape -> 29.7 & cm
  PageOrientationPortrait -> 21.0 & cm

cssPageHeight = \case
  PageOrientationLandscape -> 21.0 & cm
  PageOrientationPortrait -> 29.7 & cm

cssPrintPage :: PageOrientation -> PageSize -> CSS
cssPrintPage pageOrient pageSize =
  [
    [ ["@page"] :=
        [ "size" :=
            List.unwords
              [ pageSize & toCSS
              , pageOrient & toCSS
              ]
        ]
    ]
  ]
    & mconcat

cssBlockObjectFitCover :: CSSBlock
cssBlockObjectFitCover = ["object-fit" := "cover"]

instance ToMarkup (FilePath, Document) where
  toMarkup (dataPath, doc) =
    docTypeHtml do
      head do
        title do
          doc & documentTitle & toMarkup
        forM_ (doc & documentAttachments & Map.findWithDefault [] "css") \cssFile -> do
          link
            ! HA.rel "stylesheet"
            ! HA.type_ "text/css"
            ! HA.href (dataPath </> (cssFile & Text.unpack) & toValue)
      body do
        forM_ (doc & documentPages) \pag -> do
          pag & toMarkup
instance ToMarkup Page where
  toMarkup pag =
    div
      !? classes
        [ "page"
        , pag & pageSize & toCSS & Text.pack & Class
        , pag & pageOrientation & toCSS & Text.pack & Class
        ]
      !? styles
        [ "size" :=
            List.unwords
              [ pag & pageSize & toCSS
              , pag & pageOrientation & toCSS
              ]
        , "display" := "flex"
        ]
      $ (!? styles ["width" := "100%"])
      $ toHtml
      $ Doc.BlockFlex
        Doc.flex
          { Doc.flexDirection = Doc.FlexDirectionColumn
          , Doc.flexGap = 0.5 & Doc.cm
          , Doc.flexJustifyContent = Just JustifySpaceBetween
          , Doc.flexAlignContent = Just AlignStretch
          , Doc.flexItems =
              [ [Doc.flexItem{Doc.flexItemContent = pag & Doc.pageContent & Doc.toBlock}]
              ,
                [ Doc.flexItem
                    { Doc.flexItemContent =
                        Doc.flex
                          { Doc.flexDirection = Doc.FlexDirectionRow
                          , Doc.flexGap = 0.5 & Doc.cm
                          , Doc.flexJustifyContent = Just JustifySpaceBetween
                          , Doc.flexItems =
                              [ Doc.flexItem
                                  { Doc.flexItemContent =
                                      [ ( [ pag & Doc.pageNumber & maybe [] \n -> [n & Printf.printf "%d" & Text.pack]
                                          , pag & Doc.pageNumberTotal & maybe [] \n -> [n & Printf.printf "%d" & Text.pack]
                                          ]
                                            & mconcat
                                            & mconcat
                                            & Text.intersperse '/'
                                            & Doc.toBlock
                                        )
                                      , pag & Doc.pageSection & maybe [] Doc.toBlock
                                      ]
                                        & case pag & Doc.pageSide of
                                          Just Doc.PageSideLeft -> Doc.toBlock
                                          Just Doc.PageSideRight -> List.reverse >>> Doc.toBlock
                                          Nothing -> Doc.toBlock
                                  }
                              ]
                          }
                          & Doc.toBlock
                    }
                ]
              ]
                & mconcat
          }
instance ToMarkup Block where
  toMarkup = \case
    BlockDiv x -> x & toMarkup
    BlockFlex x -> x & toMarkup
    BlockList x -> x & toMarkup
    BlockPara x -> p $ x & toMarkup
    BlockTable x -> x & toMarkup
    BlockDict x -> x & toMarkup
    Blocks xs -> xs & foldMap toMarkup
instance ToMarkup Inline where
  toMarkup = \case
    InlineSpan x -> x & toMarkup
    InlineCode x -> code $ x & toMarkup
    InlineLink{inlineLinkText, inlineLinkTarget} ->
      ( if (inlineLinkTarget & unTarget & Doc.toInline) == inlineLinkText
          then a !? styles ["word-break" := "break-all"]
          else a
      )
        ! HA.href (inlineLinkTarget & unTarget & toValue)
        $ inlineLinkText & toMarkup
    InlineStrong x -> b $ x & toMarkup
    InlineText x -> x & toMarkup
    Inlines xs -> xs & foldMap toMarkup
instance ToMarkup FlexItem where
  toMarkup itm =
    itm
      & flexItemContent
      & toMarkup
      & ( !?
            styles
              [ "justify-self" := itm & flexItemJustifySelf & toCSS
              , "align-self" := itm & flexItemAlignSelf & toCSS
              ]
        )
instance ToMarkup (Container Block) where
  toMarkup cnt =
    (maybe elem (\anchor -> elem ! HA.id (anchor & toValue)) (cnt & containerAnchor))
      & (!? classes (cnt & containerClasses))
      $ cnt & containerContent & toMarkup
    where
      elem = case cnt & containerSemantic of
        Nothing -> div
        Just tag -> Parent (String.fromString t) (String.fromString ("<" <> t)) (String.fromString ("</" <> t <> ">"))
          where
            t = tag & unSemantic & Text.unpack
instance ToMarkup (Container Inline) where
  toMarkup
    Container
      { containerAnchor = maybeId
      , containerClasses = cls
      , containerContent = x
      } =
      (maybe span (\anchor -> span ! HA.id (anchor & toValue)) maybeId) !? classes cls $
        x & toMarkup
instance ToMarkup Flex where
  toMarkup flx =
    div
      !? styles
        [ "display" := "flex"
        , "flex-direction" := flx & flexDirection & toCSS
        , "gap" := flx & flexGap & toCSS
        , "align-content" := flx & flexAlignContent & toCSS
        , "align-items" := flx & flexAlignItems & toCSS
        , "justify-content" := flx & flexJustifyContent & toCSS
        , "justify-items" := flx & flexJustifyItems & toCSS
        , -- , "height" := "100%"
          -- FixMe(role): is it possible to avoid that to get the flex item to stretch?
          "width" := "100%"
        ]
      $ do
        forM_ (flx & flexItems) toMarkup
instance ToMarkup List where
  toMarkup List{listItems} =
    div
      !? classes ["list"]
      !? styles
        [ "grid-template-columns" :=
            [ LengthRelative LengthRelativeMaxContent
            , LengthRelative $ 1 & fr
            ]
              <&> toCSS
              & List.unwords
        ]
      $ do
        forM_ (listItems & ol1) \(itemCount, (itemKey, itemValue)) -> do
          div !? classes ["list-body", if even itemCount then "even" else "odd"] $ do
            div
              !? classes ["list-key"]
              !? styles ["justify-items" := JustifyEnd & toCSS]
              $ do
                itemKey & toMarkup
            div
              !? classes ["list-value"]
              !? styles ["justify-items" := JustifyStart & toCSS]
              $ do
                itemValue & toMarkup
instance ToMarkup Table where
  toMarkup tbl =
    div
      !? classes ["table"]
      !? styles ["grid-template-columns" := tbl & tableTemplateFinal <&> toCSS & List.unwords]
      $ do
        forM_ (tbl & tableHeads) \hd -> do
          div !? classes ["table-head"] $ do
            forM_ (hd & tableHeadColumns) \cel -> do
              div !? classes ["table-cell"] $ do
                div do
                  cel & tableCellContent & toMarkup
        forM_ (tbl & tableRows & ol1) \(rowCount, row) -> do
          div !? classes ["table-body", if even rowCount then "even" else "odd"] $ do
            forM_ (row & tableRowColumns) \cel -> do
              div
                !? classes ["table-cell"]
                !? styles ["justify-items" := cel & tableCellJustify & toCSS]
                !? styles ["align-items" := cel & tableCellAlign & toCSS]
                $ do
                  cel & tableCellContent & toMarkup
instance ToMarkup Dict where
  toMarkup dic =
    div
      !? classes ["dict"]
      $ do
        forM_ (dic & dictEntries) \(key, val) ->
          div !? classes ["dict-entry"] $ do
            div !? classes ["dict-key"] $ do
              key & toMarkup
              ":"
            -- "\x202F:"
            div !? classes ["dict-value"] $ do
              val & toMarkup