--------------------------------------------------------------------
-- |
-- Module    : Text.Atom.Feed.Export
-- Copyright : (c) Galois, Inc. 2008,
--             (c) Sigbjorn Finne 2009-
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sof@forkIO.com>
-- Stability : provisional
-- Portability:: portable
-- Description: Convert from Atom to XML
--
-- Convert from Atom to XML
--
--------------------------------------------------------------------
module Text.Atom.Feed.Export
  ( atom_prefix
  , atom_thr_prefix
  , atomNS
  , atomThreadNS
  , xmlns_atom
  , xmlns_atom_thread
  , atomName
  , atomAttr
  , atomNode
  , atomLeaf
  , atomThreadName
  , atomThreadAttr
  , atomThreadNode
  , atomThreadLeaf
  , xmlFeed
  , textFeed
  , xmlEntry
  , xmlContent
  , xmlCategory
  , xmlLink
  , xmlSource
  , xmlGenerator
  , xmlAuthor
  , xmlContributor
  , xmlPerson
  , xmlInReplyTo
  , xmlInReplyTotal
  , xmlId
  , xmlIcon
  , xmlLogo
  , xmlUpdated
  , xmlPublished
  , xmlRights
  , xmlTitle
  , xmlSubtitle
  , xmlSummary
  , xmlTextContent
  , mb
  ) where

import Prelude.Compat

import Data.Text (Text, pack)
import Data.XML.Types as XML
import Text.Atom.Feed
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Util as U

atom_prefix :: Maybe Text
atom_prefix = Nothing -- Just "atom"

atom_thr_prefix :: Maybe Text
atom_thr_prefix = Just "thr"

atomNS :: Text
atomNS = "http://www.w3.org/2005/Atom"

atomThreadNS :: Text
atomThreadNS = "http://purl.org/syndication/thread/1.0"

blank_element :: Name -> [Node] -> XML.Element
blank_element name = XML.Element name []

xmlns_atom :: Attr
xmlns_atom = (qn, [ContentText atomNS])
  where
    qn =
      case atom_prefix of
        Nothing -> Name {nameLocalName = "xmlns", nameNamespace = Nothing, namePrefix = Nothing}
        Just s ->
          Name
            { nameLocalName = s
            , nameNamespace = Nothing -- XXX: is this ok?
            , namePrefix = Just "xmlns"
            }

xmlns_atom_thread :: Attr
xmlns_atom_thread = (qn, [ContentText atomThreadNS])
  where
    qn =
      case atom_prefix of
        Nothing -> Name {nameLocalName = "xmlns", nameNamespace = Nothing, namePrefix = Nothing}
        Just s ->
          Name
            { nameLocalName = s
            , nameNamespace = Nothing -- XXX: is this ok?
            , namePrefix = Just "xmlns"
            }

atomName :: Text -> Name
atomName nc = Name {nameLocalName = nc, nameNamespace = Just atomNS, namePrefix = atom_prefix}

atomAttr :: Text -> Text -> Attr
atomAttr x y = (atomName x, [ContentText y])

atomNode :: Text -> [Node] -> XML.Element
atomNode x = blank_element (atomName x)

atomLeaf :: Text -> Text -> XML.Element
atomLeaf tag txt = blank_element (atomName tag) [NodeContent $ ContentText txt]

atomThreadName :: Text -> Name
atomThreadName nc =
  Name {nameLocalName = nc, nameNamespace = Just atomThreadNS, namePrefix = atom_thr_prefix}

atomThreadAttr :: Text -> Text -> Attr
atomThreadAttr x y = (atomThreadName x, [ContentText y])

atomThreadNode :: Text -> [Node] -> XML.Element
atomThreadNode x = blank_element (atomThreadName x)

atomThreadLeaf :: Text -> Text -> XML.Element
atomThreadLeaf tag txt = blank_element (atomThreadName tag) [NodeContent $ ContentText txt]

--------------------------------------------------------------------------------
xmlFeed :: Feed -> XML.Element
xmlFeed f =
  (atomNode "feed" $
   map NodeElement $
   [xmlTitle (feedTitle f)] ++
   [xmlId (feedId f)] ++
   [xmlUpdated (feedUpdated f)] ++
   map xmlLink (feedLinks f) ++
   map xmlAuthor (feedAuthors f) ++
   map xmlCategory (feedCategories f) ++
   map xmlContributor (feedContributors f) ++
   mb xmlGenerator (feedGenerator f) ++
   mb xmlIcon (feedIcon f) ++
   mb xmlLogo (feedLogo f) ++
   mb xmlRights (feedRights f) ++
   mb xmlSubtitle (feedSubtitle f) ++ map xmlEntry (feedEntries f) ++ feedOther f)
    {elementAttributes = [xmlns_atom]}

textFeed :: Feed -> Maybe TL.Text
textFeed = U.renderFeed xmlFeed

xmlEntry :: Entry -> XML.Element
xmlEntry e =
  (atomNode "entry" $
   map NodeElement $
   [xmlId (entryId e)] ++
   [xmlTitle (entryTitle e)] ++
   [xmlUpdated (entryUpdated e)] ++
   map xmlAuthor (entryAuthors e) ++
   map xmlCategory (entryCategories e) ++
   mb xmlContent (entryContent e) ++
   map xmlContributor (entryContributor e) ++
   map xmlLink (entryLinks e) ++
   mb xmlPublished (entryPublished e) ++
   mb xmlRights (entryRights e) ++
   mb xmlSource (entrySource e) ++
   mb xmlSummary (entrySummary e) ++
   mb xmlInReplyTo (entryInReplyTo e) ++ mb xmlInReplyTotal (entryInReplyTotal e) ++ entryOther e)
    {elementAttributes = entryAttrs e}

xmlContent :: EntryContent -> XML.Element
xmlContent cont =
  case cont of
    TextContent t -> (atomLeaf "content" t) {elementAttributes = [atomAttr "type" "text"]}
    HTMLContent x -> (atomNode "content" [NodeElement x]) {elementAttributes = [atomAttr "type" "html"]}
    XHTMLContent x ->
      (atomNode "content" [NodeElement x]) {elementAttributes = [atomAttr "type" "xhtml"]}
    MixedContent mbTy cs -> (atomNode "content" cs) {elementAttributes = mb (atomAttr "type") mbTy}
    ExternalContent mbTy src ->
      (atomNode "content" []) {elementAttributes = atomAttr "src" src : mb (atomAttr "type") mbTy}

xmlCategory :: Category -> XML.Element
xmlCategory c =
  (atomNode "category" (map NodeElement (catOther c)))
    { elementAttributes =
        [atomAttr "term" (catTerm c)] ++
        mb (atomAttr "scheme") (catScheme c) ++ mb (atomAttr "label") (catLabel c)
    }

xmlLink :: Link -> XML.Element
xmlLink l =
  (atomNode "link" (map NodeElement (linkOther l)))
    { elementAttributes =
        [atomAttr "href" (linkHref l)] ++
        mb (atomAttr "rel" . either id id) (linkRel l) ++
        mb (atomAttr "type") (linkType l) ++
        mb (atomAttr "hreflang") (linkHrefLang l) ++
        mb (atomAttr "title") (linkTitle l) ++ mb (atomAttr "length") (linkLength l) ++ linkAttrs l
    }

xmlSource :: Source -> Element
xmlSource s =
  atomNode "source" $
  map NodeElement $
  sourceOther s ++
  map xmlAuthor (sourceAuthors s) ++
  map xmlCategory (sourceCategories s) ++
  mb xmlGenerator (sourceGenerator s) ++
  mb xmlIcon (sourceIcon s) ++
  mb xmlId (sourceId s) ++
  map xmlLink (sourceLinks s) ++
  mb xmlLogo (sourceLogo s) ++
  mb xmlRights (sourceRights s) ++
  mb xmlSubtitle (sourceSubtitle s) ++
  mb xmlTitle (sourceTitle s) ++ mb xmlUpdated (sourceUpdated s)

xmlGenerator :: Generator -> Element
xmlGenerator g =
  (atomLeaf "generator" (genText g))
    {elementAttributes = mb (atomAttr "uri") (genURI g) ++ mb (atomAttr "version") (genVersion g)}

xmlAuthor :: Person -> XML.Element
xmlAuthor p = atomNode "author" (xmlPerson p)

xmlContributor :: Person -> XML.Element
xmlContributor c = atomNode "contributor" (xmlPerson c)

xmlPerson :: Person -> [XML.Node]
xmlPerson p =
  map NodeElement $
  [atomLeaf "name" (personName p)] ++
  mb (atomLeaf "uri") (personURI p) ++ mb (atomLeaf "email") (personEmail p) ++ personOther p

xmlInReplyTo :: InReplyTo -> XML.Element
xmlInReplyTo irt =
  (atomThreadNode "in-reply-to" (replyToContent irt))
    { elementAttributes =
        mb (atomThreadAttr "ref") (Just $ replyToRef irt) ++
        mb (atomThreadAttr "href") (replyToHRef irt) ++
        mb (atomThreadAttr "type") (replyToType irt) ++
        mb (atomThreadAttr "source") (replyToSource irt) ++ replyToOther irt
    }

xmlInReplyTotal :: InReplyTotal -> XML.Element
xmlInReplyTotal irt =
  (atomThreadLeaf "total" (pack $ show $ replyToTotal irt))
    {elementAttributes = replyToTotalOther irt}

xmlId :: Text -> XML.Element
xmlId = atomLeaf "id"

xmlIcon :: URI -> XML.Element
xmlIcon = atomLeaf "icon"

xmlLogo :: URI -> XML.Element
xmlLogo = atomLeaf "logo"

xmlUpdated :: Date -> XML.Element
xmlUpdated = atomLeaf "updated"

xmlPublished :: Date -> XML.Element
xmlPublished = atomLeaf "published"

xmlRights :: TextContent -> XML.Element
xmlRights = xmlTextContent "rights"

xmlTitle :: TextContent -> XML.Element
xmlTitle = xmlTextContent "title"

xmlSubtitle :: TextContent -> XML.Element
xmlSubtitle = xmlTextContent "subtitle"

xmlSummary :: TextContent -> XML.Element
xmlSummary = xmlTextContent "summary"

xmlTextContent :: Text -> TextContent -> XML.Element
xmlTextContent tg t =
  case t of
    TextString s -> (atomLeaf tg s) {elementAttributes = [atomAttr "type" "text"]}
    HTMLString s -> (atomLeaf tg s) {elementAttributes = [atomAttr "type" "html"]}
    XHTMLString e ->
      (atomNode tg [XML.NodeElement e]) {elementAttributes = [atomAttr "type" "xhtml"]}

--------------------------------------------------------------------------------
mb :: (a -> b) -> Maybe a -> [b]
mb _ Nothing = []
mb f (Just x) = [f x]