{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE Strict #-}
module Djot.Html
  ( inlinesToByteString
  , renderHtml
  , RenderOptions(..)
  )
where

import Djot.AST
import Data.Tuple (swap)
import Djot.Parse (strToUtf8)
import Djot.Options (RenderOptions(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.ByteString.Builder (Builder, byteString, word8, intDec)
import qualified Data.Sequence as Seq
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.List (sort)
import Control.Monad.State
import qualified Data.Foldable as F

renderHtml :: RenderOptions -> Doc -> Builder
renderHtml opts doc = evalState
                          ( (<>) <$> toBuilder (docBlocks doc)
                                 <*> toNotes )
                         BState{ noteMap = docFootnotes doc
                               , noteRefs = mempty
                               , renderedNotes = mempty
                               , referenceMap = docReferences doc
                                             <> docAutoReferences doc
                               , options = opts
                               }

toNotes :: State BState Builder
toNotes = do
  st <- get
  let noterefs = noteRefs st
  let numnotes = M.size noterefs
  let revnoterefs = sort $ map swap $ M.toList noterefs
  let toNote (num, lab) =
        let num' = B8.pack (show num)
        in  inTags "li" NoPos (Attr [("id", "fn" <> num')])
              ("\n" <> fromMaybe mempty (M.lookup lab (renderedNotes st)))
             <> "\n"
  if numnotes < 1
     then pure mempty
     else pure $
           inTags "section" NoPos (Attr [("role", "doc-endnotes")])
            ("\n" <> singleTag "hr" NoPos mempty <> "\n" <>
              inTags "ol" NoPos mempty ("\n" <> foldMap toNote revnoterefs) <> "\n")
             <> "\n"

addBackref :: ByteString -> Blocks -> Blocks
addBackref num (Many bls) =
    Many $
      case Seq.viewr bls of
          rest Seq.:> Node pos attr (Para ils) ->
            rest Seq.|> Node pos attr (Para (ils <> backlink))
          _ -> bls Seq.|> Node NoPos mempty (Para backlink)
 where
   backlink = Many $ Seq.singleton $
               Node NoPos (Attr [("role", "doc-backlink")])
                 (Link (str (strToUtf8 "\8617\65038"))
                 (Direct ("#fnref" <> num)))

{-# INLINE escapeHtml #-}
escapeHtml :: ByteString -> Builder
escapeHtml bs =
  if hasEscapable bs
     then B.foldl' go mempty bs
     else byteString bs
 where
  hasEscapable = B.any (\w -> w == 38 || w == 60 || w == 62)
  go b 38 = b <> byteString "&amp;"
  go b 60 = b <> byteString "&lt;"
  go b 62 = b <> byteString "&gt;"
  go b c  = b <> word8 c

{-# INLINE escapeHtmlAttribute #-}
escapeHtmlAttribute :: ByteString -> Builder
escapeHtmlAttribute bs =
  if hasEscapable bs
     then B.foldl' go mempty bs
     else byteString bs
 where
  hasEscapable = B.any (\w -> w == 38 || w == 60 || w == 62 || w == 34)
  go b 38 = b <> byteString "&amp;"
  go b 60 = b <> byteString "&lt;"
  go b 62 = b <> byteString "&gt;"
  go b 34 = b <> byteString "&quot;"
  go b c  = b <> word8 c

data BState =
  BState { noteMap :: NoteMap
         , noteRefs :: M.Map ByteString Int
         , renderedNotes :: M.Map ByteString Builder
         , referenceMap :: ReferenceMap
         , options :: RenderOptions
         }

{-# SPECIALIZE toBuilder :: Blocks -> State BState Builder #-}
{-# SPECIALIZE toBuilder :: Inlines -> State BState Builder #-}
class ToBuilder a where
  toBuilder :: a -> State BState Builder

instance ToBuilder Inlines where
  toBuilder = fmap F.fold . mapM toBuilder . unMany

instance ToBuilder Blocks where
  toBuilder = fmap F.fold . mapM toBuilder . unMany

instance ToBuilder (Node Block) where
  toBuilder (Node pos attr bl) =
    let addNl = (<> "\n") in
    case bl of
      Para ils -> addNl . inTags "p" pos attr <$> toBuilder ils
      Heading lev ils ->
        let tag = case lev of
                    1 -> "h1"
                    2 -> "h2"
                    3 -> "h3"
                    4 -> "h4"
                    5 -> "h5"
                    6 -> "h6"
                    _ -> "p"
        in  addNl . inTags tag pos attr <$> toBuilder ils
      Section bls -> do
        contents <- toBuilder bls
        pure $ addNl $ inTags "section" pos attr $ "\n" <> contents
      ThematicBreak -> pure $ addNl $ singleTag "hr" pos attr
      BulletList listSpacing items ->
        addNl . inTags "ul" pos attr . ("\n" <>) . mconcat <$> mapM toLi items
          where
            toLi bls = addNl . inTags "li" NoPos mempty . ("\n" <>) <$>
                          toItemContents listSpacing bls
      OrderedList listAttr listSpacing items ->
        addNl . inTags "ol" pos (Attr [("start", strToUtf8 (show start))
                                  | start /= 1]
                              <> Attr [("type", typ) | typ /= "1"] <> attr)
         . ("\n" <>) . mconcat <$> mapM toLi items
          where
            typ = case orderedListStyle listAttr of
                    Decimal -> "1"
                    LetterUpper -> "A"
                    LetterLower -> "a"
                    RomanUpper -> "I"
                    RomanLower -> "i"
            start = orderedListStart listAttr
            toLi bls = addNl . inTags "li" NoPos mempty . ("\n" <>)
                          <$> toItemContents listSpacing bls
      DefinitionList listSpacing defs ->
        addNl . inTags "dl" pos attr . ("\n" <>) . mconcat
          <$> mapM (toDefinition listSpacing) defs
      TaskList listSpacing items ->
        addNl . inTags "ul" pos (Attr [("class", "task-list")] <> attr)
          . ("\n" <>) . mconcat <$> mapM (toTaskListItem listSpacing) items
      Div bls -> addNl . inTags "div" pos attr . ("\n" <>) <$> toBuilder bls
      BlockQuote bls ->
        addNl . inTags "blockquote" pos attr . ("\n" <>) <$> toBuilder bls
      CodeBlock lang bs -> pure $
        inTags "pre" pos attr (inTags "code" NoPos codeattr (escapeHtml bs))
          <> "\n"
         where
           codeattr = if B.null lang
                         then mempty
                         else Attr [("class", "language-" <> lang)]
      Table mbCaption rows -> do
        rows' <- mapM toRow rows
        capt <- case mbCaption of
                   Nothing -> pure mempty
                   Just (Caption bs) ->
                     addNl . inTags "caption" NoPos mempty
                       <$> case F.toList (unMany bs) of
                              [Node _pos at (Para ils)] | at == mempty
                                 -> toBuilder ils
                              _ -> ("\n" <>) <$> toBuilder bs
        pure $ addNl . inTags "table" pos attr . ("\n" <>) $ capt <> mconcat rows'
      RawBlock (Format "html") bs -> pure $ byteString bs
      RawBlock _ _ -> pure mempty

toRow :: [Cell] -> State BState Builder
toRow cells = (<> "\n") . inTags "tr" NoPos mempty . ("\n" <>) . mconcat
                <$> mapM toCell cells

toCell :: Cell -> State BState Builder
toCell (Cell cellType align ils) =
  (<> "\n") . inTags (if cellType == HeadCell
                         then "th"
                         else "td") NoPos attr <$> toBuilder ils
 where
   attr = Attr $ case align of
                   AlignDefault -> []
                   AlignLeft -> [("style", "text-align: left;")]
                   AlignRight -> [("style", "text-align: right;")]
                   AlignCenter -> [("style", "text-align: center;")]


toItemContents :: ListSpacing -> Blocks -> State BState Builder
toItemContents listSpacing = fmap F.fold . mapM go . unMany
 where
   go (Node pos attr bl) =
    case bl of
      Para ils
        | listSpacing == Tight ->
            if attr == mempty
               then (<> "\n") <$> toBuilder ils
               else (<> "\n") . inTags "span" pos attr <$> toBuilder ils
        | otherwise -> toBuilder (Node pos attr bl)
      _ -> toBuilder (Node pos attr bl)

toTaskListItem :: ListSpacing -> (TaskStatus, Blocks) -> State BState Builder
toTaskListItem listSpacing (status, bs) = do
  body <- case Seq.viewl $ unMany bs of
            Node pos attr (Para ils) Seq.:< rest ->
              toItemContents listSpacing (Many
                (Node pos attr
                 (Para (rawInline (Format "html") ("<label>" <> input) <>
                         ils <>
                         rawInline (Format "html") "</label>")) Seq.<| rest))
            _ -> toBuilder $ rawBlock (Format "html") input <> bs
  pure $ inTags "li" NoPos (Attr [("class", if status == Complete
                                             then "checked"
                                             else "unchecked")])  ("\n" <> body) <> "\n"
 where
   inputattr = " type=\"checkbox\"" <>
               if status == Complete then " checked=\"\"" else ""
   input = "<input" <> inputattr <> " />"

toDefinition :: ListSpacing -> (Inlines, Blocks) -> State BState Builder
toDefinition listSpacing (term, defn) = (<>) <$>
  ((<> "\n") . inTags "dt" NoPos mempty <$> toBuilder term) <*>
  ((<> "\n") . inTags "dd" NoPos mempty . ("\n" <>) <$> toItemContents listSpacing defn)

instance ToBuilder (Node Inline) where
  toBuilder (Node pos attr il) =
    case il of
      Str bs -> case attr of
                   Attr [] | pos == NoPos -> pure $ escapeHtml bs
                   _ -> pure $ inTags "span" pos attr $ escapeHtml bs
      SoftBreak -> do
        opts <- gets options
        pure $ word8 $ if preserveSoftBreaks opts then 10 else 32
      HardBreak -> pure $ singleTag "br" NoPos attr <> "\n"
      NonBreakingSpace -> pure $ byteString "&nbsp;"
      Emph ils -> inTags "em" pos attr <$> toBuilder ils
      Strong ils -> inTags "strong" pos attr <$> toBuilder ils
      Highlight ils -> inTags "mark" pos attr <$> toBuilder ils
      Insert ils -> inTags "ins" pos attr <$> toBuilder ils
      Delete ils -> inTags "del" pos attr <$> toBuilder ils
      Superscript ils -> inTags "sup" pos attr <$> toBuilder ils
      Subscript ils -> inTags "sub" pos attr <$> toBuilder ils
      Quoted SingleQuotes ils -> inSingleQuotes <$> toBuilder ils
      Quoted DoubleQuotes ils -> inDoubleQuotes <$> toBuilder ils
      Verbatim bs -> pure $ inTags "code" pos attr (escapeHtml bs)
      Math DisplayMath bs -> pure $
        inTags "span" pos (Attr [("class", "math display")] <> attr)
          ("\\[" <> escapeHtml bs <> "\\]")
      Math InlineMath bs -> pure $
        inTags "span" pos (Attr [("class", "math inline")] <> attr)
          ("\\(" <> escapeHtml bs <> "\\)")
      Symbol bs -> pure $
        inTags "span" pos (Attr [("class", "symbol")] <> attr)
          (":" <> escapeHtml bs <> ":")
      Span ils -> inTags "span" pos attr <$> toBuilder ils
      Link ils target -> do
        attr' <- case target of
                   Direct u -> pure $ Attr [("href", u)]
                   Reference label -> do
                     rm <- gets referenceMap
                     case lookupReference label rm of
                       Nothing -> pure $ Attr [("href", "")]
                       Just (u, Attr as) -> pure $ Attr (("href",u):as)
        inTags "a" pos (attr' <> attr) <$> toBuilder ils
      Image ils target -> do
        attr' <- case target of
                   Direct u -> pure $ Attr [("src", u)]
                   Reference label -> do
                     rm <- gets referenceMap
                     case lookupReference label rm of
                       Nothing -> pure $ Attr [("src", "")]
                       Just (u, Attr as) -> pure $ Attr (("src",u):as)
        pure $ singleTag "img" pos
                 (Attr [("alt", inlinesToByteString ils)] <> attr' <> attr)
      EmailLink email ->
        toBuilder (Node pos attr (Link (str email) (Direct ("mailto:" <> email))))
      UrlLink url -> toBuilder (Node pos attr (Link (str url) (Direct url)))
      RawInline (Format "html") bs -> pure $ byteString bs
      RawInline _ _ -> pure mempty
      FootnoteReference label -> do
        noterefs <- gets noteRefs
        notemap <- gets noteMap
        num <- case M.lookup label noterefs of
                 Just num -> pure num
                 Nothing -> do
                   let num = M.size noterefs + 1
                   modify $ \st -> st{ noteRefs = M.insert label num noterefs }
                   renderedNotesMap <- gets renderedNotes
                   case M.lookup label renderedNotesMap of
                     Just _ -> pure ()
                     Nothing -> do -- render the note and add to renderedNotes
                       let num' = B8.pack (show num)
                       rendered <- maybe (toBuilder $ addBackref num' (mempty :: Blocks))
                                    (toBuilder . addBackref num') (lookupNote label notemap)
                       modify $ \st -> st{ renderedNotes =
                                             M.insert label rendered (renderedNotes st) }
                   pure num
        let num' = B8.pack $ show num
        pure $ inTags "a" pos (Attr [("id", "fnref" <> num'),
                                     ("href", "#fn" <> num'),
                                     ("role", "doc-noteref")] <> attr) $
                 inTags "sup" pos mempty (escapeHtml num')

{-# INLINE inTags #-}
inTags :: ByteString -> Pos -> Attr -> Builder -> Builder
inTags tag pos attr contents =
  "<" <> byteString tag <> posToBuilder pos
      <> attrToBuilder attr <> ">" <> contents
      <> "</" <> byteString tag <> ">"


{-# INLINE singleTag #-}
singleTag :: ByteString -> Pos -> Attr -> Builder
singleTag tag pos attr =
  "<" <> byteString tag <> posToBuilder pos <> attrToBuilder attr <> ">"

{-# INLINE attrToBuilder #-}
attrToBuilder :: Attr -> Builder
attrToBuilder (Attr pairs) = foldMap go pairs
 where
   go (k,v) = " " <> byteString k <> "=\"" <> escapeHtmlAttribute v <> "\""

{-# INLINE posToBuilder #-}
posToBuilder :: Pos -> Builder
posToBuilder NoPos = mempty
posToBuilder (Pos sl sc el ec) =
  " data-pos=\"" <> intDec sl <> ":" <> intDec sc <> "-" <>
     intDec el <> ":" <> intDec ec <> "\""

inSingleQuotes :: Builder -> Builder
inSingleQuotes x =
  byteString (strToUtf8 "\x2018") <> x <> byteString (strToUtf8 "\x2019")

inDoubleQuotes :: Builder -> Builder
inDoubleQuotes x =
  byteString (strToUtf8 "\x201C") <> x <> byteString (strToUtf8 "\x201D")