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

import Control.Monad (forM_, mapM_)
import Data.Bool
import Data.Function (($), (.))
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.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
			xmlBlocks blocks
	 DTC.Block v -> xmlBlock 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
	 $ xmlLines lines

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 $ xmlLines 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

xmlBlocks :: DTC.Blocks -> XML
xmlBlocks = (`forM_` xmlBlock)

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)

xmlBlock :: DTC.Block -> XML
xmlBlock = \case
	 DTC.Para{..} ->
		xmlCommonAttrs attrs $
		XML.para $ xmlLines lines
	 DTC.OL{..} ->
		xmlCommonAttrs attrs $
		XML.ol $ forM_ items $ XML.li . xmlBlocks
	 DTC.UL{..} ->
		xmlCommonAttrs attrs $
		XML.ul $ forM_ items $ XML.li . xmlBlocks
	 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

xmlLines :: DTC.Lines -> XML
xmlLines = (`forM_` xmlLine)

xmlLine :: Tree DTC.LineKey DTC.LineValue -> XML
xmlLine = \case
 Tree0 v ->
	case v of
	 DTC.Plain p -> B.toMarkup p
	 DTC.BR      -> XML.br
 TreeN k ls ->
	case k of
	 DTC.B        -> XML.b    $ xmlLines ls
	 DTC.Code     -> XML.code $ xmlLines ls
	 DTC.Del      -> XML.del  $ xmlLines ls
	 DTC.I        -> XML.i    $ xmlLines ls
	 DTC.Note     -> XML.note $ xmlLines ls
	 DTC.Q        -> XML.q    $ xmlLines ls
	 DTC.SC       -> XML.sc   $ xmlLines ls
	 DTC.Sub      -> XML.sub  $ xmlLines ls
	 DTC.Sup      -> XML.sup  $ xmlLines ls
	 DTC.Eref to  -> XML.eref ! XA.to (attrValue to) $ xmlLines ls
	 DTC.Iref{..} -> XML.iref ! XA.term (attrValue $ plainifyWords term) $ xmlLines ls
	 DTC.Ref  to  -> XML.ref  ! XA.to (attrValue to) $ xmlLines ls
	 DTC.Rref to  -> XML.rref ! XA.to (attrValue to) $ xmlLines ls

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