--------------------------------------------------------------------
-- |
-- 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 :: String
xml_header = String
"<?xml version='1.0' ?>"


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

-- | Default pretty orinting configuration.
--  * Always use abbreviate empty tags.
defaultConfigPP :: ConfigPP
defaultConfigPP :: ConfigPP
defaultConfigPP = ConfigPP { shortEmptyTag :: QName -> Bool
shortEmptyTag = Bool -> QName -> Bool
forall a b. a -> b -> a
const Bool
True
                           , prettify :: Bool
prettify      = Bool
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 :: (QName -> Bool) -> ConfigPP -> ConfigPP
useShortEmptyTags QName -> Bool
p ConfigPP
c = ConfigPP
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 :: Bool -> ConfigPP -> ConfigPP
useExtraWhiteSpace Bool
p ConfigPP
c  = ConfigPP
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 :: ConfigPP
prettyConfigPP      = Bool -> ConfigPP -> ConfigPP
useExtraWhiteSpace Bool
True ConfigPP
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 :: Element -> String
ppTopElement        = ConfigPP -> Element -> String
ppcTopElement ConfigPP
prettyConfigPP

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

-- | Pretty printing content
ppContent          :: Content -> String
ppContent :: Content -> String
ppContent           = ConfigPP -> Content -> String
ppcContent ConfigPP
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 :: ConfigPP -> Element -> String
ppcTopElement ConfigPP
c Element
e   = [String] -> String
unlines [String
xml_header,ConfigPP -> Element -> String
ppcElement ConfigPP
c Element
e]

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

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





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

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

ppCDataS           :: ConfigPP -> String -> CData -> ShowS
ppCDataS :: ConfigPP -> String -> CData -> ShowS
ppCDataS ConfigPP
c String
i CData
t String
xs   = String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ if CData -> CDataKind
cdVerbatim CData
t CDataKind -> CDataKind -> Bool
forall a. Eq a => a -> a -> Bool
/= CDataKind
CDataText Bool -> Bool -> Bool
|| Bool -> Bool
not (ConfigPP -> Bool
prettify ConfigPP
c)
                             then CData -> ShowS
showCDataS CData
t String
xs
                             else (Char -> ShowS) -> String -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
cons String
xs (CData -> String
showCData CData
t)

  where cons         :: Char -> String -> String
        cons :: Char -> ShowS
cons Char
'\n' String
ys  = String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ys
        cons Char
y String
ys     = Char
y Char -> ShowS
forall a. a -> [a] -> [a]
: String
ys



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

-- | Adds the <?xml?> header.
showTopElement     :: Element -> String
showTopElement :: Element -> String
showTopElement Element
c    = String
xml_header String -> ShowS
forall a. [a] -> [a] -> [a]
++ Element -> String
showElement Element
c

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

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

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

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

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

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

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

  -- NOTE: We escape '\r' explicitly because otherwise they get lost
  -- when parsed back in because of then end-of-line normalization rules.
  Char
_ | Char -> Bool
isPrint Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' -> Char -> ShowS
showChar Char
c
    | Bool
otherwise -> String -> ShowS
showString String
"&#" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
oc ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
';'
      where oc :: Int
oc = Char -> Int
ord Char
c

escStr             :: String -> ShowS
escStr :: String -> ShowS
escStr String
cs String
rs        = (Char -> ShowS) -> String -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
escChar String
rs String
cs

tagEnd             :: QName -> ShowS
tagEnd :: QName -> ShowS
tagEnd QName
qn String
rs        = Char
'<'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:QName -> String
showQName QName
qn String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'>'Char -> ShowS
forall a. a -> [a] -> [a]
:String
rs

tagStart           :: QName -> [Attr] -> ShowS
tagStart :: QName -> [Attr] -> ShowS
tagStart QName
qn [Attr]
as String
rs   = Char
'<'Char -> ShowS
forall a. a -> [a] -> [a]
:QName -> String
showQName QName
qn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
as_str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rs
 where as_str :: String
as_str       = if [Attr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attr]
as then String
"" else Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: [String] -> String
unwords ((Attr -> String) -> [Attr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Attr -> String
showAttr [Attr]
as)

showAttr           :: Attr -> String
showAttr :: Attr -> String
showAttr (Attr QName
qn String
v) = QName -> String
showQName QName
qn String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'=' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'"' Char -> ShowS
forall a. a -> [a] -> [a]
: String -> ShowS
escStr String
v String
"\""

showQName          :: QName -> String
showQName :: QName -> String
showQName QName
q         = String
pre String -> ShowS
forall a. [a] -> [a] -> [a]
++ QName -> String
qName QName
q
  where pre :: String
pre = case QName -> Maybe String
qPrefix QName
q of
                Maybe String
Nothing -> String
""
                Just String
p  -> String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"