{-# 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.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
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 Data.Text.Lazy as TL
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.Anchor (plainifyWords)
import qualified Language.DTC.Document as DTC

document :: Locales ls => LocaleIn ls -> DTC.Document -> XML
document 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

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

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

xmlBody :: DTC.Body -> XML
xmlBody = mapM_ $ \(Tree n ts) ->
	case n of
	 DTC.Section{..} ->
		xmlCommonAttrs attrs $
		XML.section $ do
			xmlTitle title
			forM_ aliases xmlAlias
			xmlBody ts
	 DTC.ToC{..} ->
		xmlCommonAttrs attrs $
		XML.toc
		 !?? mayAttr XA.depth depth
	 DTC.ToF{..} ->
		xmlCommonAttrs attrs $
		XML.tof $
			XML.ul $
				forM_ types $
					XML.li . xmlText
	 DTC.Index{..} ->
		xmlCommonAttrs attrs $
		XML.index $ do
			XML.ul $
				forM_ terms $ \aliases ->
					XML.li $
						xmlText $
						TL.unlines $
						plainifyWords <$> aliases
	 DTC.Figure{..} ->
		xmlCommonAttrs attrs $
		XML.figure
		 ! XA.type_ (attrify type_) $ do
			forM_ mayTitle xmlTitle
			xmlBlocks blocks
	 DTC.References{..} ->
		xmlCommonAttrs attrs $
		XML.references $ forM_ refs $ xmlReference
	 DTC.Block v -> xmlBlock v

xmlAbout :: DTC.About -> XML
xmlAbout DTC.About{..} = do
	forM_ titles   $ xmlTitle
	forM_ authors  $ xmlEntity
	forM_ editor   $ xmlEntity
	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 (attrify href)

xmlKeyword :: TL.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 (attrify 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
	 $ xmlPara para

xmlEntity :: DTC.Entity -> XML
xmlEntity DTC.Entity{..} =
	XML.entity
	 !?? mayAttr XA.name    name
	 !?? 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

xmlTitle :: DTC.Title -> XML
xmlTitle (DTC.Title t) = XML.title $ xmlPara 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 $ attrify 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.String $ TL.unpack i) .
	case classes of
	 [] -> \m -> m
	 _ ->
		B.AddCustomAttribute "class" $
		B.String $ TL.unpack $ TL.unwords classes

xmlBlock :: DTC.Block -> XML
xmlBlock = \case
	 DTC.Para{..} ->
		xmlCommonAttrs attrs $
		XML.para $ xmlPara para
	 DTC.OL{..} ->
		xmlCommonAttrs attrs $
		XML.ol $ forM_ items $ XML.li . xmlBlocks
	 DTC.UL{..} ->
		xmlCommonAttrs attrs $
		XML.ul $ forM_ items $ XML.li . xmlBlocks
	 DTC.Comment c ->
		XML.comment $ TL.toStrict c
	 DTC.Artwork{..} ->
		xmlCommonAttrs attrs $
		XML.artwork
		 ! XA.type_ (attrify type_) $ do
			xmlText text
	 DTC.Quote{..} ->
		xmlCommonAttrs attrs $
		XML.quote
		 ! XA.type_ (attrify type_) $ do
			xmlBlocks blocks

xmlPara :: DTC.Para -> XML
xmlPara = (`forM_` xmlLine)

xmlLine :: DTC.Lines -> XML
xmlLine (Tree n ls) =
	case n of
	 DTC.Plain p -> B.toMarkup p
	 DTC.BR      -> XML.br
	 DTC.B        -> XML.b    $ xmlPara ls
	 DTC.Code     -> XML.code $ xmlPara ls
	 DTC.Del      -> XML.del  $ xmlPara ls
	 DTC.I        -> XML.i    $ xmlPara ls
	 DTC.Note{..} -> XML.note $ xmlPara ls
	 DTC.Q        -> XML.q    $ xmlPara ls
	 DTC.SC       -> XML.sc   $ xmlPara ls
	 DTC.Sub      -> XML.sub  $ xmlPara ls
	 DTC.Sup      -> XML.sup  $ xmlPara ls
	 DTC.U        -> XML.u    $ xmlPara ls
	 DTC.Eref to  -> XML.eref ! XA.to (attrify to) $ xmlPara ls
	 DTC.Iref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlPara ls
	 DTC.Ref  to  -> XML.ref  ! XA.to (attrify to) $ xmlPara ls
	 DTC.Rref{..} -> XML.rref ! XA.to (attrify to) $ xmlPara ls

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