{-# 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.Text qualified as Text
import Data.Text.Short qualified as ShortText
import Literate.Document qualified as Doc
import Literate.Document.Table
import Literate.Document.Type hiding (classes, div)
import Literate.Prelude
import Text.Blaze
import Text.Blaze.Html5
import Text.Blaze.Html5.Attributes qualified as HA
import Text.Blaze.Renderer.Utf8

instance IsString AttributeValue
instance IsString Html

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

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 -> Attribute
styles kvs =
  HA.style $
    [ toValue k <> ":" <> toValue v <> ";"
    | (k, v) <- kvs & Map.toList
    , not (null v)
    ]
      & mconcat

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 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"

cssPageWidth = \case
  PageOrientationLandscape -> 29.7 & cm
  PageOrientationPortrait -> 21.0 & cm
cssPageHeight = \case
  PageOrientationLandscape -> 21.0 & cm
  PageOrientationPortrait -> 29.7 & cm
cssPageSize = \case
  PageSizeA5 -> "A5"
  PageSizeA4 -> "A4"
  PageSizeA4Plus -> "A4plus"
  PageSizeA3 -> "A3"
cssPageOrientation = \case
  PageOrientationPortrait -> "portrait"
  PageOrientationLandscape -> "landscape"

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

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

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
    InlineText x -> x & toMarkup
    InlineCode x -> code $ x & toMarkup
    InlineLink{inlineLinkText, inlineLinkTarget} ->
      a ! HA.href (inlineLinkTarget & unTarget & toValue) $ inlineLinkText & toMarkup
    Inlines xs -> xs & foldMap toMarkup
instance ToMarkup FlexItem where
  toMarkup itm =
    forM_ (itm & flexItemContent) toMarkup
instance ToMarkup Div where
  toMarkup
    Div
      { divAnchor = maybeId
      , divClasses = cls
      , divBlock = x
      } =
      (maybe div (\anchor -> div ! 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
        ]
      $ 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" := JustificationRight & toCSS]
              $ do
                itemKey & toMarkup
            div
              ! classes ["list-value"]
              ! styles ["justify-items" := JustificationLeft & 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]
                $ 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
instance ToCSS Justification where
  toCSS = \case
    JustificationLeft -> "left"
    JustificationBegin -> "begin"
    JustificationCenter -> "center"
    JustificationEnd -> "end"
    JustificationRight -> "right"
instance ToCSS FlexDirection where
  toCSS = \case
    FlexDirectionColumn -> "column"
    FlexDirectionRow -> "row"