content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  -- |
  -- Copyright   : (c) 2011 Simon Meier
  -- License     : GPL v3 (see LICENSE)
  -- 
  -- Portability : portable
  --
  -- Pretty-printing with support for HTML markup and proper HTML escaping.
  module Text.PrettyPrint.Html (
    -- * HtmlDocument class
      HtmlDocument(..)
  
    , withTag
    , withTagNonEmpty
    , closedTag
  
    , module Text.PrettyPrint.Highlight
  
    -- * HtmlDoc: adding HTML markup
    , HtmlDoc
    , htmlDoc
    , getHtmlDoc
    , postprocessHtmlDoc
    , renderHtmlDoc
  
    -- * NoHtmlDoc: ignoring HTML markup
    , noHtmlDoc
    , getNoHtmlDoc
    ) where
  
  import Data.Char (isSpace)
  -- import Data.Traversable (sequenceA)
  -- import Data.Monoid
  
  import Control.Arrow (first)
  import Control.Applicative
  import Control.Monad.Identity
  import Control.DeepSeq
  
  import Text.PrettyPrint.Class
  import Text.PrettyPrint.Highlight
  
  ------------------------------------------------------------------------------
  -- HtmlDocument class
  ------------------------------------------------------------------------------
  
  
  class HighlightDocument d => HtmlDocument d where
      -- | @unescapedText str@ converts the 'String' @str@ to a document without
      -- performing any escaping.
      unescapedText :: String -> d
  
      -- | @unescapedZeroWidthText str@ converts the 'String' @str@ to a document
      -- with zero width without performing any escaping.
      unescapedZeroWidthText :: String -> d
  
  -- | @withTag tag attrs inner@ adds the tag @tag@ with the attributes
  -- @attrs@ around the @inner@ document.
  withTag :: HtmlDocument d => String -> [(String,String)] -> d -> d
  withTag tag attrs inner =
      unescapedZeroWidthText open <> inner <> unescapedZeroWidthText close
    where
      open  = "<" ++ tag ++ concatMap attribute attrs ++ ">"
      close = "</" ++ tag ++ ">"
  
  -- | @closedTag tag attrs@ builds the closed tag @tag@ with the attributes
  -- @attrs@; e.g.,
  --
  -- > closedTag "img" "href" "here" = HtmlDoc (text "<img href=\"here\"/>)
  --
  closedTag :: HtmlDocument d => String -> [(String,String)] -> d
  closedTag tag attrs = 
      unescapedZeroWidthText $ "<" ++ tag ++ concatMap attribute attrs ++ "/>"
  
  -- | @withTagNonEmpty tag attrs inner@ adds the tag @tag@ with the attributes
  -- @attrs@ around the @inner@ document iff @inner@ is a non-empty document.
  withTagNonEmpty :: HtmlDocument d => String -> [(String,String)] -> d -> d
  withTagNonEmpty tag attrs inner =
      caseEmptyDoc inner emptyDoc $ withTag tag attrs inner
  
  -- | Render an attribute.
  attribute :: (String, String) -> String
  attribute (key,value) = " " ++ key ++ "=\"" ++ escapeHtmlEntities value ++ "\""
  
  
  ------------------------------------------------------------------------------
  -- HtmlDoc: adding HTML markup
  ------------------------------------------------------------------------------
  
  -- | A 'Document' transformer that adds proper HTML escaping.
  newtype HtmlDoc d = HtmlDoc { getHtmlDoc :: d }
      deriving( Monoid, Semigroup )
  
  -- | Wrap a document such that HTML markup can be added without disturbing the
  -- layout.
  htmlDoc :: d -> HtmlDoc d
  htmlDoc = HtmlDoc
  
  instance NFData d => NFData (HtmlDoc d) where
      rnf = rnf . getHtmlDoc
  
  instance Document d => Document (HtmlDoc d) where
      char          = HtmlDoc . text . escapeHtmlEntities . return
      text          = HtmlDoc . text . escapeHtmlEntities 
      zeroWidthText = HtmlDoc . zeroWidthText . escapeHtmlEntities
  
      HtmlDoc d1 <-> HtmlDoc d2 = HtmlDoc $ d1 <-> d2
      hcat = HtmlDoc . hcat . map getHtmlDoc
      hsep = HtmlDoc . hsep . map getHtmlDoc
  
      HtmlDoc d1 $$  HtmlDoc d2 = HtmlDoc $ d1 $$ d2
      HtmlDoc d1 $-$ HtmlDoc d2 = HtmlDoc $ d1 $-$ d2
      vcat = HtmlDoc . vcat . map getHtmlDoc
  
      sep = HtmlDoc . sep . map getHtmlDoc
      cat = HtmlDoc . cat . map getHtmlDoc
  
      fsep = HtmlDoc . fsep . map getHtmlDoc
      fcat = HtmlDoc . fcat . map getHtmlDoc
  
      nest i = HtmlDoc . nest i . getHtmlDoc
      caseEmptyDoc (HtmlDoc d1) (HtmlDoc d2) (HtmlDoc d3) = 
          HtmlDoc $ caseEmptyDoc d1 d2 d3
  
  instance Document d => HtmlDocument (HtmlDoc d) where
      unescapedText = HtmlDoc . text
      unescapedZeroWidthText = HtmlDoc . zeroWidthText
  
  instance Document d => HighlightDocument (HtmlDoc d) where
      highlight hlStyle = 
          withTag "span" [("class", hlClass hlStyle)]
        where
          hlClass Comment  = "hl_comment"
          hlClass Keyword  = "hl_keyword"
          hlClass Operator = "hl_operator"
  
  -- | Escape HTML entities in a string
  --
  -- Copied from 'blaze-html'.
  escapeHtmlEntities :: String  -- ^ String to escape
                     -> String  -- ^ Resulting string
  escapeHtmlEntities []     = []
  escapeHtmlEntities (c:cs) = case c of
      '<'  -> "&lt;"   ++ escapeHtmlEntities cs
      '>'  -> "&gt;"   ++ escapeHtmlEntities cs
      '&'  -> "&amp;"  ++ escapeHtmlEntities cs
      '"'  -> "&quot;" ++ escapeHtmlEntities cs
      '\'' -> "&#39;"  ++ escapeHtmlEntities cs
      x    -> x : escapeHtmlEntities cs
  
  -- | @renderHtmlDoc = 'postprocessHtmlDoc' . 'render' . 'getHtmlDoc'@ 
  renderHtmlDoc :: HtmlDoc Doc -> String
  renderHtmlDoc = postprocessHtmlDoc . render . getHtmlDoc
  
  -- | @postprocessHtmlDoc cs@ converts the line-breaks of @cs@ to @<br>@ tags and
  -- the prefixed spaces in every line of @cs@ by non-breaing HTML spaces @&nbsp;@.
  postprocessHtmlDoc :: String -> String
  postprocessHtmlDoc = 
      unlines . map (addBreak . indent) . lines
    where
      addBreak = (++"<br/>")
      indent   = uncurry (++) . (first $ concatMap (const "&nbsp;")) . span isSpace
  
  ------------------------------------------------------------------------------
  -- NoHtmlDoc: ignoring HTML markup
  ------------------------------------------------------------------------------
  
  -- | A 'Document' transformer that ignores all 'HtmlDocument' specific methods.
  newtype NoHtmlDoc d = NoHtmlDoc { unNoHtmlDoc :: Identity d }
    deriving( Functor, Applicative )
  
  
  -- | Wrap a document such that all 'HtmlDocument' specific methods are ignored.
  noHtmlDoc :: d -> NoHtmlDoc d
  noHtmlDoc = NoHtmlDoc . Identity
  
  -- | Extract the wrapped document.
  getNoHtmlDoc :: NoHtmlDoc d -> d
  getNoHtmlDoc = runIdentity . unNoHtmlDoc
  
  instance NFData d => NFData (NoHtmlDoc d) where
      rnf = rnf . getNoHtmlDoc
  
  instance Semigroup d => Semigroup (NoHtmlDoc d) where
    (<>) = liftA2 (<>)
  
  instance Monoid d => Monoid (NoHtmlDoc d) where
    mempty = pure mempty
  
  instance Document d => Document (NoHtmlDoc d) where
    char = pure . char
    text = pure . text
    zeroWidthText = pure . zeroWidthText
    (<->) = liftA2 (<->)
    hcat  = liftA hcat . sequenceA
    hsep  = liftA hsep . sequenceA
    ($$)  = liftA2 ($$)
    ($-$) = liftA2 ($-$)
    vcat  = liftA vcat  . sequenceA
    sep   = liftA sep   . sequenceA
    cat   = liftA cat   . sequenceA
    fsep  = liftA fsep  . sequenceA
    fcat  = liftA fcat  . sequenceA
    nest  = liftA2 nest . pure
    caseEmptyDoc = liftA3 caseEmptyDoc
  
  instance Document d => HtmlDocument (NoHtmlDoc d) where
      unescapedText          = noHtmlDoc . text
      unescapedZeroWidthText = noHtmlDoc . zeroWidthText
  
  instance Document d => HighlightDocument (NoHtmlDoc d) where
      highlight _ = id
  