    -----------------------------------------------------------------------------
    -- |
    -- Module      :  HSP.XML
    -- Copyright   :  (c) Niklas Broberg 2008-2013
    -- License     :  BSD-style (see the file LICENSE.txt)
    --
    -- Maintainer  :  Niklas Broberg, niklas.broberg@gmail.com
    -- Stability   :  experimental
    -- Portability :  Haskell 98
    --
    -- Datatypes and type classes comprising the basic model behind
    -- the scenes of Haskell Server Pages tags.
    -----------------------------------------------------------------------------
    module HSP.XML (
            -- * The 'XML' datatype
            XML(..),
            XMLMetaData(..),
            Namespace,
            NSName,
            Attributes,
            Children,
            pcdata,
            cdata,
            -- * The Attribute type
            Attribute(..),
            AttrValue(..),
            attrVal, pAttrVal,
            -- * Functions
            renderXML,
            isElement, isCDATA,
            fromStringLit
            ) where

    import Data.List                        (intersperse)
    import Data.Monoid                      ((<>), mconcat)
    import Data.String                      (fromString)
    import Data.Text.Lazy.Builder           (Builder, fromLazyText, singleton, toLazyText)
    import Data.Text.Lazy                   (Text)
    import qualified Data.Text.Lazy         as Text
    import HSP.XML.PCDATA                   (escape)

    ---------------------------------------------------------------
    -- fromStringLit

    fromStringLit :: String -> Text
    fromStringLit :: String -> Text
    fromStringLit = String -> Text
    Text.pack

    ---------------------------------------------------------------
    -- Namespace/NSName

    type Namespace  = Maybe Text
    type NSName = (Namespace, Text)

    ---------------------------------------------------------------
    -- Attributes
    newtype Attribute = MkAttr (NSName, AttrValue)
      deriving Int -> Attribute -> ShowS
    [Attribute] -> ShowS
    Attribute -> String
    (Int -> Attribute -> ShowS)
    -> (Attribute -> String)
    -> ([Attribute] -> ShowS)
    -> Show Attribute
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Attribute -> ShowS
    showsPrec :: Int -> Attribute -> ShowS
    $cshow :: Attribute -> String
    show :: Attribute -> String
    $cshowList :: [Attribute] -> ShowS
    showList :: [Attribute] -> ShowS
    Show

    -- | Represents an attribue value.
    data AttrValue = Value Bool Text | NoValue

    -- fromStringLit :: String -> Text
    -- fromStringLit = Text.pack

    -- | Create an attribue value from a string.
    attrVal, pAttrVal :: Text -> AttrValue
    attrVal :: Text -> AttrValue
    attrVal  = Bool -> Text -> AttrValue
    Value Bool
    False
    pAttrVal :: Text -> AttrValue
    pAttrVal = Bool -> Text -> AttrValue
    Value Bool
    True

    instance Show AttrValue where
     show :: AttrValue -> String
    show (Value Bool
    _ Text
    txt) = Text -> String
    Text.unpack Text
    txt
     show AttrValue
    NoValue = String
    ""

    type Attributes = [Attribute]

    ---------------------------------------------------------------
    -- XML
    -- | The XML datatype representation. Is either an Element or CDATA.
    data XML
        = Element NSName Attributes Children
        | CDATA Bool Text
          deriving Int -> XML -> ShowS
    [XML] -> ShowS
    XML -> String
    (Int -> XML -> ShowS)
    -> (XML -> String) -> ([XML] -> ShowS) -> Show XML
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> XML -> ShowS
    showsPrec :: Int -> XML -> ShowS
    $cshow :: XML -> String
    show :: XML -> String
    $cshowList :: [XML] -> ShowS
    showList :: [XML] -> ShowS
    Show

    type Children = [XML]

    -- | Embeds a string as a CDATA XML value.
    cdata , pcdata :: Text -> XML
    cdata :: Text -> XML
    cdata  = Bool -> Text -> XML
    CDATA Bool
    False
    pcdata :: Text -> XML
    pcdata = Bool -> Text -> XML
    CDATA Bool
    True

    -- | Test whether an XML value is an Element or CDATA
    isElement, isCDATA :: XML -> Bool
    isElement :: XML -> Bool
    isElement (Element {}) = Bool
    True
    isElement XML
    _ = Bool
    False
    isCDATA :: XML -> Bool
    isCDATA = Bool -> Bool
    not (Bool -> Bool) -> (XML -> Bool) -> XML -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XML -> Bool
    isElement

    ---------------------------------------------------------------
    -- XMLMetaData

    -- |The XMLMetaData datatype
    --
    -- Specify the DOCTYPE, content-type, and preferred render for XML data.
    --
    -- See also: 'HSP.Monad.setMetaData' and 'HSP.Monad.withMetaData'
    data XMLMetaData = XMLMetaData
      {  XMLMetaData -> (Bool, Text)
    doctype           :: (Bool, Text) -- ^ (show doctype when rendering, DOCTYPE string)
      ,  XMLMetaData -> Text
    contentType       :: Text
      ,  XMLMetaData -> XML -> Builder
    preferredRenderer :: XML -> Builder
      }

    ------------------------------------------------------------------
    -- Rendering

    data TagType = Open | Close | Single

    renderTag :: TagType -> Int -> NSName -> Attributes -> Builder
    renderTag :: TagType -> Int -> NSName -> [Attribute] -> Builder
    renderTag TagType
    typ Int
    n NSName
    name [Attribute]
    attrs =
            let (Builder
    start,Builder
    end) = case TagType
    typ of
                               TagType
    Open   -> (Char -> Builder
    singleton  Char
    '<',  Char -> Builder
    singleton  Char
    '>')
                               TagType
    Close  -> (String -> Builder
    forall a. IsString a => String -> a
    fromString String
    "</", Char -> Builder
    singleton  Char
    '>')
                               TagType
    Single -> (Char -> Builder
    singleton  Char
    '<',  String -> Builder
    forall a. IsString a => String -> a
    fromString String
    "/>")
                nam :: Builder
    nam = NSName -> Builder
    showNSName NSName
    name
                as :: Builder
    as  = [Attribute] -> Builder
    renderAttrs [Attribute]
    attrs
             in [Builder] -> Builder
    forall a. Monoid a => [a] -> a
    mconcat [Builder
    start, Builder
    nam, Builder
    as, Builder
    end]

      where renderAttrs :: Attributes -> Builder
            renderAttrs :: [Attribute] -> Builder
    renderAttrs [] = Builder
    nl
            renderAttrs [Attribute]
    attrs' = Char -> Builder
    singleton Char
    ' ' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> [Builder] -> Builder
    forall a. Monoid a => [a] -> a
    mconcat  [Builder]
    ats Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <>  Builder
    nl
              where ats :: [Builder]
    ats = Builder -> [Builder] -> [Builder]
    forall a. a -> [a] -> [a]
    intersperse (Char -> Builder
    singleton Char
    ' ') ([Builder] -> [Builder]) -> [Builder] -> [Builder]
    forall a b. (a -> b) -> a -> b
    $ (Attribute -> Builder) -> [Attribute] -> [Builder]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Attribute -> Builder
    renderAttr [Attribute]
    attrs'

            renderAttr :: Attribute -> Builder
            renderAttr :: Attribute -> Builder
    renderAttr (MkAttr (NSName
    nam, (Value Bool
    needsEscape Text
    val))) =
                NSName -> Builder
    showNSName NSName
    nam Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    '=' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder -> Builder
    renderAttrVal  (if Bool
    needsEscape then Text -> Builder
    escape Text
    val else Text -> Builder
    fromLazyText Text
    val)
            renderAttr (MkAttr (NSName
    nam, AttrValue
    NoValue)) = NSName -> Builder
    showNSName NSName
    nam Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    '=' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder -> Builder
    renderAttrVal (String -> Builder
    forall a. IsString a => String -> a
    fromString String
    "")

            renderAttrVal :: Builder -> Builder
            renderAttrVal :: Builder -> Builder
    renderAttrVal Builder
    txt = Char -> Builder
    singleton Char
    '\"' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    txt Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    '\"'

            showNSName :: NSName -> Builder
    showNSName (Maybe Text
    Nothing, Text
    s) = Text -> Builder
    fromLazyText Text
    s
            showNSName (Just Text
    d, Text
    s)  = Text -> Builder
    fromLazyText Text
    d Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    ':' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Builder
    fromLazyText Text
    s

            nl :: Builder
    nl = Char -> Builder
    singleton Char
    '\n' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> String -> Builder
    forall a. IsString a => String -> a
    fromString (Int -> Char -> String
    forall a. Int -> a -> [a]
    replicate Int
    n Char
    ' ')

    renderXML' :: Int -> XML -> Builder
    renderXML' :: Int -> XML -> Builder
    renderXML' Int
    _ (CDATA Bool
    needsEscape Text
    cd) = if Bool
    needsEscape then Text -> Builder
    escape Text
    cd else Text -> Builder
    fromLazyText Text
    cd
    renderXML' Int
    n (Element NSName
    name [Attribute]
    attrs []) = TagType -> Int -> NSName -> [Attribute] -> Builder
    renderTag TagType
    Single Int
    n NSName
    name [Attribute]
    attrs
    renderXML' Int
    n (Element NSName
    name [Attribute]
    attrs [XML]
    children) =
            let open :: Builder
    open  = TagType -> Int -> NSName -> [Attribute] -> Builder
    renderTag TagType
    Open Int
    n NSName
    name [Attribute]
    attrs
                cs :: Builder
    cs    = Int -> [XML] -> Builder
    renderChildren Int
    n [XML]
    children
                close :: Builder
    close = TagType -> Int -> NSName -> [Attribute] -> Builder
    renderTag TagType
    Close Int
    n NSName
    name []
             in Builder
    open Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    cs Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    close

      where renderChildren :: Int -> Children -> Builder
            renderChildren :: Int -> [XML] -> Builder
    renderChildren Int
    n' [XML]
    cs = [Builder] -> Builder
    forall a. Monoid a => [a] -> a
    mconcat ([Builder] -> Builder) -> [Builder] -> Builder
    forall a b. (a -> b) -> a -> b
    $ (XML -> Builder) -> [XML] -> [Builder]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> XML -> Builder
    renderXML' (Int
    n'Int -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    2)) [XML]
    cs

    -- TODO: indents are incorrectly calculated

    -- | Pretty-prints XML values.
    renderXML :: XML -> Text
    renderXML :: XML -> Text
    renderXML XML
    xml = Builder -> Text
    toLazyText (Builder -> Text) -> Builder -> Text
    forall a b. (a -> b) -> a -> b
    $ Int -> XML -> Builder
    renderXML' Int
    0 XML
    xml