{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.DTC.Write.XML where

-- import Data.Foldable (Foldable(..))
import Control.Monad (forM_, mapM_)
import Data.Bool
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Text.Blaze ((!))
import Text.Blaze.Utils
import Text.Blaze.XML (XML)
import Data.TreeSeq.Strict (Tree(..))
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Text.Blaze as B
import qualified Text.Blaze.DTC as XML
import qualified Text.Blaze.DTC.Attributes as XA
import qualified Text.Blaze.Internal as B

import Data.Locale
import Language.DTC.Document (MayText(..), whenMayText)
import Language.DTC.Index (plainifyWords)
import qualified Language.DTC.Document as DTC

xmlText :: Text -> XML
xmlText = B.toMarkup

xmlDocument :: Locales ls => LocaleIn ls -> DTC.Document -> XML
xmlDocument loc DTC.Document{..} = do
	let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
	XML.xmlModel "./schema/dtc.rnc"
	XML.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
	XML.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
	XML.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
	XML.document $ do
		xmlHead head
		xmlBody body

xmlHead :: DTC.Head -> XML
xmlHead DTC.Head{..} =
	XML.about $ xmlAbout about

xmlBody :: DTC.Body -> XML
xmlBody = mapM_ $ \case
	 TreeN k ts -> xmlBodyKey k $ xmlBody ts
	 Tree0 v -> xmlBodyValue v

xmlBodyKey :: DTC.BodyKey -> XML -> XML
xmlBodyKey k body = case k of
	 DTC.Section{..} ->
		xmlCommonAttrs attrs $
		XML.section $ do
			xmlTitle title
			forM_ aliases xmlAlias
			body

xmlBodyValue :: DTC.BodyValue -> XML
xmlBodyValue = \case
	 DTC.ToC{..} ->
		xmlCommonAttrs attrs $
		XML.toc
		 !?? mayAttr XA.depth depth
	 DTC.ToF{..} ->
		xmlCommonAttrs attrs $
		XML.tof
		 !?? mayAttr XA.depth depth
	 DTC.Figure{..} ->
		xmlCommonAttrs attrs $
		XML.figure
		 ! XA.type_ (attrValue type_) $ do
			xmlTitle title
			xmlVerticals verts
	 DTC.Vertical v -> xmlVertical v

xmlAbout :: DTC.About -> XML
xmlAbout DTC.About{..} = do
	forM_ titles   $ xmlTitle
	forM_ authors  $ xmlAuthor
	forM_ editor   $ xmlEditor
	forM_ date     $ xmlDate
	whenMayText version xmlVersion
	forM_ keywords $ xmlKeyword
	forM_ links    $ xmlLink
	forM_ includes $ xmlInclude

xmlInclude :: DTC.Include -> XML
xmlInclude DTC.Include{..} =
	XML.include True
	 ! XA.href (attrValue href)

xmlKeyword :: Text -> XML
xmlKeyword = XML.keyword . xmlText

xmlVersion :: MayText -> XML
xmlVersion (MayText t) = XML.version $ xmlText t

xmlDate :: DTC.Date -> XML
xmlDate DTC.Date{..} =
	XML.date
	 !   XA.year (attrValue year)
	 !?? mayAttr XA.month month
	 !?? mayAttr XA.day day

xmlLink :: DTC.Link -> XML
xmlLink DTC.Link{..} =
	XML.link
	 !?? mayAttr XA.name name
	 !?? mayAttr XA.rel  rel
	 !?? mayAttr XA.href href
	 $ xmlHorizontals body

xmlAddress :: DTC.Address -> XML
xmlAddress DTC.Address{..} =
	XML.address
	 !?? mayAttr XA.street street
	 !?? mayAttr XA.zipcode zipcode
	 !?? mayAttr XA.city    city
	 !?? mayAttr XA.region  region
	 !?? mayAttr XA.country country
	 !?? mayAttr XA.email   email
	 !?? mayAttr XA.tel     tel
	 !?? mayAttr XA.fax     fax

xmlAuthor :: DTC.Entity -> XML
xmlAuthor DTC.Entity{..} =
	XML.author
	 !?? mayAttr XA.name name
	 $ xmlAddress address

xmlEditor :: DTC.Entity -> XML
xmlEditor DTC.Entity{..} =
	XML.editor
	 !?? mayAttr XA.name name
	 $ xmlAddress address

xmlTitle :: DTC.Title -> XML
xmlTitle (DTC.Title t) = XML.title $ xmlHorizontals t

xmlAlias :: DTC.Alias -> XML
xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id

xmlId :: DTC.Ident -> B.Attribute
xmlId (DTC.Ident i) = XA.id $ attrValue i

xmlVerticals :: DTC.Verticals -> XML
xmlVerticals = (`forM_` xmlVertical)

xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
	(case ident of
	 Nothing -> \m -> m
	 Just (DTC.Ident i)  -> B.AddCustomAttribute "id" (B.Text i)) .
	case classes of
	 [] -> \m -> m
	 _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords classes)

xmlVertical :: DTC.Vertical -> XML
xmlVertical = \case
	 DTC.Para{..} ->
		xmlCommonAttrs attrs $
		XML.para $ xmlHorizontals horis
	 DTC.OL{..} ->
		xmlCommonAttrs attrs $
		XML.ol $ forM_ items $ XML.li . xmlVerticals
	 DTC.UL{..} ->
		xmlCommonAttrs attrs $
		XML.ul $ forM_ items $ XML.li . xmlVerticals
	 DTC.RL{..} ->
		xmlCommonAttrs attrs $
		XML.rl $ forM_ refs $ xmlReference
	 -- DTC.Index -> XML.index
	 DTC.Comment c ->
		XML.comment c
	 DTC.Artwork{..} ->
		xmlCommonAttrs attrs $
		XML.artwork mempty

xmlHorizontals :: DTC.Horizontals -> XML
xmlHorizontals = (`forM_` xmlHorizontal)

xmlHorizontal :: DTC.Horizontal -> XML
xmlHorizontal = \case
 DTC.Plain txt  -> B.toMarkup txt
 DTC.BR         -> XML.br
 DTC.B    hs    -> XML.b    $ xmlHorizontals hs
 DTC.Code hs    -> XML.code $ xmlHorizontals hs
 DTC.Del  hs    -> XML.del  $ xmlHorizontals hs
 DTC.I    hs    -> XML.i    $ xmlHorizontals hs
 DTC.Note hs    -> XML.note $ xmlHorizontals hs
 DTC.Q    hs    -> XML.q    $ xmlHorizontals hs
 DTC.SC   hs    -> XML.sc   $ xmlHorizontals hs
 DTC.Sub  hs    -> XML.sub  $ xmlHorizontals hs
 DTC.Sup  hs    -> XML.sup  $ xmlHorizontals hs
 DTC.Eref to hs -> XML.eref ! XA.to (attrValue to) $ xmlHorizontals hs
 DTC.Iref{..}   -> XML.iref ! XA.term (attrValue $ plainifyWords term) $ xmlHorizontals text
 DTC.Ref  to hs -> XML.ref  ! XA.to (attrValue to) $ xmlHorizontals hs
 DTC.Rref to hs -> XML.rref ! XA.to (attrValue to) $ xmlHorizontals hs

xmlReference :: DTC.Reference -> XML
xmlReference DTC.Reference{..} =
	XML.reference mempty