    --------------------------------------------------------------------
    -- |
    -- 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 :: QName -> Bool
    shortEmptyTag = QName -> Bool
    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 :: Bool
    prettify = Bool
    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
    ":"