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

import Control.Monad (forM_)
import Data.Bool
-- import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Text.Blaze ((!))
import Text.Blaze.DTC (XML)
import Text.Blaze.Utils
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 Language.DTC.Document (MayText(..), whenMayText)
import qualified Language.DTC.Document as DTC

instance AttrValue DTC.URL where
	attrValue (DTC.URL a) = attrValue a
instance AttrValue DTC.Path where
	attrValue (DTC.Path a) = attrValue a
instance AttrValue DTC.Ident where
	attrValue (DTC.Ident a) = attrValue a
instance AttrValue DTC.Nat where
	attrValue (DTC.Nat a) = attrValue a
instance AttrValue DTC.Nat1 where
	attrValue (DTC.Nat1 a) = attrValue a

instance MayAttr DTC.URL where
	mayAttr a (DTC.URL t) = mayAttr a t
instance MayAttr DTC.Path where
	mayAttr a (DTC.Path t) = mayAttr a t
instance MayAttr DTC.Ident where
	mayAttr a (DTC.Ident t) = mayAttr a t
instance MayAttr DTC.Nat where
	mayAttr a (DTC.Nat t) = mayAttr a t
instance MayAttr DTC.Nat1 where
	mayAttr a (DTC.Nat1 t) = mayAttr a t

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

xmlDocument :: DTC.Document -> XML
xmlDocument DTC.Document{..} = do
	let lang = "fr"
	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
		xmlVerticals body

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

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=DTC.Ident ident, ..} =
	(case ident of
	 "" -> \m -> m
	 i  -> B.AddCustomAttribute "id" (B.Text i)) .
	case class_ of
	 [] -> \m -> m
	 _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords class_)

xmlVertical :: DTC.Vertical -> XML
xmlVertical = \case
	 DTC.Section{..} ->
		xmlCommonAttrs attrs $
		XML.section $ do
			xmlTitle title
			forM_ aliases xmlAlias
			xmlVerticals body
	 DTC.Para as hs ->
		xmlCommonAttrs as $
		XML.para $ xmlHorizontals hs
	 DTC.OL as vs ->
		xmlCommonAttrs as $
		XML.ol $ forM_ vs $ XML.li . xmlVerticals
	 DTC.UL as vs ->
		xmlCommonAttrs as $
		XML.ul $ forM_ vs $ XML.li . xmlVerticals
	 DTC.ToC as d ->
		xmlCommonAttrs as $
		XML.toc
		 !?? mayAttr XA.depth d
	 DTC.ToF as d ->
		xmlCommonAttrs as $
		XML.tof
		 !?? mayAttr XA.depth d
	 DTC.RL as rs ->
		xmlCommonAttrs as $
		XML.rl $ forM_ rs $ xmlReference
	 -- DTC.Index -> XML.index
	 DTC.Figure{..} ->
		xmlCommonAttrs attrs $
		XML.figure
		 ! XA.type_ (attrValue type_) $ do
			xmlTitle title
			xmlVerticals body
	 DTC.Comment c ->
		XML.comment c
	 DTC.Artwork as _art ->
		xmlCommonAttrs as $
		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 to hs -> XML.iref ! XA.to (attrValue to) $ xmlHorizontals hs
 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