-----------------------------------------------------------------------------
-- |
-- 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 _ txt :: Text
txt) = Text -> String
Text.unpack Text
txt
 show NoValue = ""

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 _ = 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 typ :: TagType
typ n :: Int
n name :: NSName
name attrs :: [Attribute]
attrs =
        let (start :: Builder
start,end :: Builder
end) = case TagType
typ of
                           Open   -> (Char -> Builder
singleton  '<',  Char -> Builder
singleton  '>')
                           Close  -> (String -> Builder
forall a. IsString a => String -> a
fromString "</", Char -> Builder
singleton  '>')
                           Single -> (Char -> Builder
singleton  '<',  String -> Builder
forall a. IsString a => String -> a
fromString "/>")
            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 attrs' :: [Attribute]
attrs' = Char -> Builder
singleton ' ' 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 ' ') ([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 (nam :: NSName
nam, (Value needsEscape :: Bool
needsEscape val :: Text
val))) =
            NSName -> Builder
showNSName NSName
nam Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton '=' 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 (nam :: NSName
nam, NoValue)) = NSName -> Builder
showNSName NSName
nam Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton '=' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
renderAttrVal (String -> Builder
forall a. IsString a => String -> a
fromString "")

        renderAttrVal :: Builder -> Builder
        renderAttrVal :: Builder -> Builder
renderAttrVal txt :: Builder
txt = Char -> Builder
singleton '\"' 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 '\"'

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

        nl :: Builder
nl = Char -> Builder
singleton '\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 ' ')

renderXML' :: Int -> XML -> Builder
renderXML' :: Int -> XML -> Builder
renderXML' _ (CDATA needsEscape :: Bool
needsEscape cd :: Text
cd) = if Bool
needsEscape then Text -> Builder
escape Text
cd else Text -> Builder
fromLazyText Text
cd
renderXML' n :: Int
n (Element name :: NSName
name attrs :: [Attribute]
attrs []) = TagType -> Int -> NSName -> [Attribute] -> Builder
renderTag TagType
Single Int
n NSName
name [Attribute]
attrs
renderXML' n :: Int
n (Element name :: NSName
name attrs :: [Attribute]
attrs children :: [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 n' :: Int
n' cs :: [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
+2)) [XML]
cs

-- TODO: indents are incorrectly calculated

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