--------------------------------------------------------------------
-- |
-- Module    : Text.XML.Light.Output
-- Copyright : (c) Galois, Inc. 2007
-- License   : BSD3
--
-- Maintainer: Iavor S. Diatchki <diatchki@galois.com>
-- Stability : provisional
-- Portability:
--
-- Output handling for the lightweight XML lib.
--

module Text.XML.Light.Output
  ( showTopElement, showContent, showElement, showCData, showQName, showAttr
  , ppTopElement, ppContent, ppElement
  , ppcTopElement, ppcContent, ppcElement
  , ConfigPP
  , defaultConfigPP, prettyConfigPP
  , useShortEmptyTags, useExtraWhiteSpace
  , tagEnd, xml_header
  ) where

import Text.XML.Light.Types
import Data.Char
import Data.List ( isPrefixOf )

-- | The XML 1.0 header
xml_header :: String
xml_header = "<?xml version='1.0' ?>"


--------------------------------------------------------------------------------
data ConfigPP = ConfigPP
  { shortEmptyTag :: QName -> Bool
  , prettify      :: Bool
  }

-- | Default pretty orinting configuration.
--  * Always use abbreviate empty tags.
defaultConfigPP :: ConfigPP
defaultConfigPP = ConfigPP { shortEmptyTag = const True
                           , prettify      = False
                           }

-- | The predicate specifies for which empty tags we should use XML's
-- abbreviated notation <TAG />.  This is useful if we are working with
-- some XML-ish standards (such as certain versions of HTML) where some
-- empty tags should always be displayed in the <TAG></TAG> form.
useShortEmptyTags :: (QName -> Bool) -> ConfigPP -> ConfigPP
useShortEmptyTags p c = c { shortEmptyTag = p }


-- | Specify if we should use extra white-space to make document more readable.
-- WARNING: This adds additional white-space to text elements,
-- and so it may change the meaning of the document.
useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
useExtraWhiteSpace p c  = c { prettify = p }

-- | A configuration that tries to make things pretty
-- (possibly at the cost of changing the semantics a bit
-- through adding white space.)
prettyConfigPP     :: ConfigPP
prettyConfigPP      = useExtraWhiteSpace True defaultConfigPP


--------------------------------------------------------------------------------


-- | Pretty printing renders XML documents faithfully,
-- with the exception that whitespace may be added\/removed
-- in non-verbatim character data.
ppTopElement       :: Element -> String
ppTopElement        = ppcTopElement prettyConfigPP

-- | Pretty printing elements
ppElement          :: Element -> String
ppElement           = ppcElement prettyConfigPP

-- | Pretty printing content
ppContent          :: Content -> String
ppContent           = ppcContent prettyConfigPP



-- | Pretty printing renders XML documents faithfully,
-- with the exception that whitespace may be added\/removed
-- in non-verbatim character data.
ppcTopElement      :: ConfigPP -> Element -> String
ppcTopElement c e   = unlines [xml_header,ppcElement c e]

-- | Pretty printing elements
ppcElement         :: ConfigPP -> Element -> String
ppcElement c e      = ppElementS c "" e ""

-- | Pretty printing content
ppcContent         :: ConfigPP -> Content -> String
ppcContent c x      = ppContentS c "" x ""





-- | Pretty printing content using ShowS
ppContentS         :: ConfigPP -> String -> Content -> ShowS
ppContentS c i x xs = case x of
                        Elem e -> ppElementS c i e xs
                        Text t -> ppCDataS c i t xs
                        CRef r -> showCRefS r xs

ppElementS         :: ConfigPP -> String -> Element -> ShowS
ppElementS c i e xs = i ++ (tagStart (elName e) (elAttribs e) $
  case elContent e of
    [] | "?" `isPrefixOf` qName name -> " ?>" ++ xs
       | shortEmptyTag c name  -> " />" ++ xs
    [Text t] -> ">" ++ ppCDataS c "" t (tagEnd name xs)
    cs -> '>' : nl ++ foldr ppSub (i ++ tagEnd name xs) cs
      where ppSub e1 = ppContentS c (sp ++ i) e1 . showString nl
            (nl,sp)  = if prettify c then ("\n","  ") else ("","")
  )
  where name = elName e

ppCDataS           :: ConfigPP -> String -> CData -> ShowS
ppCDataS c i t xs   = i ++ if cdVerbatim t /= CDataText || not (prettify c)
                             then showCDataS t xs
                             else foldr cons xs (showCData t)

  where cons         :: Char -> String -> String
        cons '\n' ys  = "\n" ++ i ++ ys
        cons y ys     = y : ys



--------------------------------------------------------------------------------

-- | Adds the <?xml?> header.
showTopElement     :: Element -> String
showTopElement c    = xml_header ++ showElement c

showContent        :: Content -> String
showContent c       = ppContentS defaultConfigPP "" c ""

showElement        :: Element -> String
showElement c       = ppElementS defaultConfigPP "" c ""

showCData          :: CData -> String
showCData c         = ppCDataS defaultConfigPP "" c ""

-- Note: crefs should not contain '&', ';', etc.
showCRefS          :: String -> ShowS
showCRefS r xs      = '&' : r ++ ';' : xs

-- | Convert a text element to characters.
showCDataS         :: CData -> ShowS
showCDataS cd =
 case cdVerbatim cd of
   CDataText     -> escStr (cdData cd)
   CDataVerbatim -> showString "<![CDATA[" . escCData (cdData cd)
                                           . showString "]]>"
   CDataRaw      -> \ xs -> cdData cd ++ xs

--------------------------------------------------------------------------------
escCData           :: String -> ShowS
escCData (']' : ']' : '>' : cs) = showString "]]]]><![CDATA[>" . escCData cs
escCData (c : cs)               = showChar c . escCData cs
escCData []                     = id

escChar            :: Char -> ShowS
escChar c = case c of
  '<'   -> showString "&lt;"
  '>'   -> showString "&gt;"
  '&'   -> showString "&amp;"
  '"'   -> showString "&quot;"
  -- we use &#39 instead of &apos; because IE apparently has difficulties
  -- rendering &apos; in xhtml.
  -- Reported by Rohan Drape <rohan.drape@gmail.com>.
  '\''  -> showString "&#39;"

  -- NOTE: We escape '\r' explicitly because otherwise they get lost
  -- when parsed back in because of then end-of-line normalization rules.
  _ | isPrint c || c == '\n' -> showChar c
    | otherwise -> showString "&#" . shows oc . showChar ';'
      where oc = ord c

escStr             :: String -> ShowS
escStr cs rs        = foldr escChar rs cs

tagEnd             :: QName -> ShowS
tagEnd qn rs        = '<':'/':showQName qn ++ '>':rs

tagStart           :: QName -> [Attr] -> ShowS
tagStart qn as rs   = '<':showQName qn ++ as_str ++ rs
 where as_str       = if null as then "" else ' ' : unwords (map showAttr as)

showAttr           :: Attr -> String
showAttr (Attr qn v) = showQName qn ++ '=' : '"' : escStr v "\""

showQName          :: QName -> String
showQName q         = pre ++ qName q
  where pre = case qPrefix q of
                Nothing -> ""
                Just p  -> p ++ ":"