module Handler.Utils.Pandoc
  ( htmlField, htmlFieldSmall
  , renderMarkdownWith, parseMarkdownWith
  , htmlReaderOptions, markdownReaderOptions
  , markdownWriterOptions, htmlWriterOptions
  ) where

import Import.NoFoundation
import Handler.Utils.I18n

import qualified Data.Text as Text
import qualified Data.Text.Lazy as LT

import Control.Monad.Error.Class (liftEither)

import qualified Text.Pandoc as P

import Text.Blaze (preEscapedText)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.HTML.SanitizeXSS (sanitizeBalance)


data HtmlFieldKind
  = HtmlFieldNormal
  | HtmlFieldSmall
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe HtmlFieldKind
instance Finite HtmlFieldKind

htmlField, htmlFieldSmall :: MonadLogger m => Field m StoredMarkup
htmlField = htmlField' HtmlFieldNormal
htmlFieldSmall = htmlField' HtmlFieldSmall


htmlField' :: MonadLogger m => HtmlFieldKind -> Field m StoredMarkup
htmlField' fieldKind = Field{..}
  where
    fieldEnctype = UrlEncoded

    fieldParse ((Text.strip -> t) : _) _ = runExceptT . runMaybeT $ do
      html <- assertM' (not . null . LT.strip . renderHtml) =<< liftEither (parseMarkdown t)
      return StoredMarkup
        { markupInputFormat = MarkupMarkdown
        , markupInput = fromStrict t
        , markupOutput = html
        }
    fieldParse []     _ = return $ Right Nothing

    fieldView theId name attrs val isReq = do
      val'
        <- let toMarkdown StoredMarkup{..} = case markupInputFormat of
                 MarkupMarkdown -> return $ toStrict markupInput
                 MarkupHtml -> renderMarkdown markupOutput
                 MarkupPlaintext -> plaintextToMarkdown $ toStrict markupInput
            in either return (maybeT (return mempty) . toMarkdown) val
                    
      let markdownExplanation = $(i18nWidgetFile "markdown-explanation")
      $(widgetFile "widgets/html-field")

    parseMarkdown  = parseMarkdownWith  markdownReaderOptions htmlWriterOptions
    renderMarkdown = renderMarkdownWith htmlReaderOptions     markdownWriterOptions
    plaintextToMarkdown = plaintextToMarkdownWith markdownWriterOptions

parseMarkdownWith :: P.ReaderOptions -> P.WriterOptions -> Text -> Either (SomeMessage site) Html
parseMarkdownWith readerOptions writerOptions text =
  bimap pandocError (preEscapedText . sanitizeBalance) . P.runPure $
    P.writeHtml5String writerOptions =<< P.readMarkdown readerOptions text
  where
    pandocError = SomeMessage . tshow

renderMarkdownWith :: (MonadLogger m, MonadPlus m) => P.ReaderOptions -> P.WriterOptions -> Html -> m Text
renderMarkdownWith readerOptions writerOptions html =
  either (\e -> logPandocError e >> mzero) return . P.runPure $
    P.writeMarkdown writerOptions =<< P.readHtml readerOptions (toStrict $ renderHtml html)
  where
    logPandocError = $logErrorS "renderMarkdown" . tshow

plaintextToMarkdownWith :: (MonadLogger m, MonadPlus m) => P.WriterOptions -> Text -> m Text
plaintextToMarkdownWith writerOptions text =
  either (\e -> logPandocError e >> mzero) return . P.runPure $
    P.writeMarkdown writerOptions pandoc
  where
    logPandocError = $logErrorS "renderMarkdown" . tshow
    pandoc = P.Pandoc mempty [P.Plain [P.Str text]]


htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
htmlReaderOptions = markdownReaderOptions
markdownReaderOptions = def
  { P.readerExtensions = P.pandocExtensions
      & P.enableExtension P.Ext_hard_line_breaks
      & P.enableExtension P.Ext_autolink_bare_uris
  , P.readerTabStop = 2
  }

markdownWriterOptions, htmlWriterOptions :: P.WriterOptions
markdownWriterOptions = def
  { P.writerExtensions = P.readerExtensions markdownReaderOptions
  , P.writerTabStop = P.readerTabStop markdownReaderOptions
  }
htmlWriterOptions = markdownWriterOptions