-----------------------------------------------------------------------------
-- |
-- 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
showList :: [Attribute] -> ShowS
$cshowList :: [Attribute] -> ShowS
show :: Attribute -> String
$cshow :: Attribute -> String
showsPrec :: Int -> Attribute -> ShowS
$cshowsPrec :: Int -> 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
showList :: [XML] -> ShowS
$cshowList :: [XML] -> ShowS
show :: XML -> String
$cshow :: XML -> String
showsPrec :: Int -> XML -> ShowS
$cshowsPrec :: Int -> 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 (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