{-# LANGUAGE FlexibleInstances #-}
{-# 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.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.TreeSeq.Strict (Tree(..))
import Text.Blaze ((!))
import Text.Blaze.Utils
import Text.Blaze.XML (XML)
import qualified Data.Char as Char
import qualified Data.Function as Fun
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.Anchor (plainifyWords)
import Language.DTC.Document as DTC hiding (XML)

document :: Locales ls => LocaleIn ls -> Document -> XML
document loc 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
		xmlify head
		xmlify body

-- * Class 'Xmlify'
class Xmlify a where
	xmlify :: a -> XML

instance Xmlify TL.Text where
	xmlify = B.toMarkup
instance Xmlify Head where
	xmlify Head{..} =
		xmlify about
instance Xmlify (Tree BodyNode) where
	xmlify (Tree n ts) =
		case n of
		 BodyBlock b -> xmlify b
		 BodySection{..} ->
			xmlCommonAttrs attrs $
			XML.section $ do
				xmlify title
				forM_ aliases xmlify
				xmlify ts
instance Xmlify Block where
	xmlify = \case
	 BlockPara para -> xmlify para
	 BlockToC{..} ->
		xmlCommonAttrs attrs $
		XML.toc
		 !?? mayAttr XA.depth depth
	 BlockToF{..} ->
		xmlCommonAttrs attrs $
		XML.tof $
			XML.ul $
				forM_ types $
					XML.li . xmlify
	 BlockIndex{..} ->
		xmlCommonAttrs attrs $
		XML.index $ do
			XML.ul $
				forM_ terms $ \aliases ->
					XML.li $
						xmlify $
						TL.unlines $
						plainifyWords <$> aliases
	 BlockFigure{..} ->
		xmlCommonAttrs attrs $
		XML.figure
		 ! XA.type_ (attrify type_) $ do
			xmlify mayTitle
			xmlify paras
	 BlockReferences{..} ->
		xmlCommonAttrs attrs $
		XML.references $ xmlify refs
instance Xmlify Para where
	xmlify = \case
	 ParaItem{..}  -> xmlify item
	 ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items
instance Xmlify ParaItem where
	xmlify = \case
	 ParaPlain p -> XML.p $ xmlify p
	 ParaComment c ->
		XML.comment $ TL.toStrict c
	 ParaArtwork{..} ->
		XML.artwork
		 ! XA.type_ (attrify type_) $ do
			xmlify text
	 ParaQuote{..} ->
		XML.quote
		 ! XA.type_ (attrify type_) $ do
			xmlify paras
	 ParaOL items -> XML.ol $ forM_ items xmlify
	 ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify
instance Xmlify ListItem where
	xmlify ListItem{..} =
		XML.li ! XA.name (attrify name) $ xmlify paras
instance Xmlify (Tree PlainNode) where
	xmlify (Tree n ts) =
		case n of
		 PlainText t   -> xmlify t
		 PlainBR       -> XML.br
		 PlainGroup    -> xmlify ts
		 PlainB        -> XML.b    $ xmlify ts
		 PlainCode     -> XML.code $ xmlify ts
		 PlainDel      -> XML.del  $ xmlify ts
		 PlainI        -> XML.i    $ xmlify ts
		 PlainNote{..} -> XML.note $ xmlify note
		 PlainQ        -> XML.q    $ xmlify ts
		 PlainSC       -> XML.sc   $ xmlify ts
		 PlainSub      -> XML.sub  $ xmlify ts
		 PlainSup      -> XML.sup  $ xmlify ts
		 PlainU        -> XML.u    $ xmlify ts
		 PlainEref to  -> XML.eref ! XA.to (attrify to) $ xmlify ts
		 PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts
		 PlainRef  to  -> XML.ref  ! XA.to (attrify to) $ xmlify ts
		 PlainRref{..} -> XML.rref ! XA.to (attrify to) $ xmlify ts

instance Xmlify About where
	xmlify About{..} = do
		XML.about
		 !?? mayAttr XA.url url
		 $ do
			xmlify titles
			xmlify authors
			xmlify editor
			xmlify date
			forM_ tags $ XML.tag . xmlify
			xmlify links
			xmlify includes
instance Xmlify Include where
	xmlify Include{..} =
		XML.include True
		 ! XA.href (attrify href)
instance Xmlify Date where
	xmlify Date{..} =
		XML.date
		 !   XA.year (attrify year)
		 !?? mayAttr XA.month month
		 !?? mayAttr XA.day day
instance Xmlify Link where
	xmlify Link{..} =
		XML.link
		 !?? mayAttr XA.name name
		 !?? mayAttr XA.rel  rel
		 !?? mayAttr XA.href href
		 $ xmlify plain
instance Xmlify Entity where
	xmlify 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
instance Xmlify Title where
	xmlify (Title t) = XML.title $ xmlify t
instance Xmlify Alias where
	xmlify Alias{..} = XML.alias !?? mayAttr XA.id id
instance Xmlify Reference where
	xmlify Reference{..} = XML.reference mempty -- TODO: to be coded

instance Xmlify a => Xmlify (Maybe a) where
	xmlify = foldMap xmlify
instance Xmlify a => Xmlify [a] where
	xmlify = foldMap xmlify
instance Xmlify a => Xmlify (Seq a) where
	xmlify = foldMap xmlify

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

xmlCommonAttrs :: CommonAttrs -> XML -> XML
xmlCommonAttrs CommonAttrs{id=ident, ..} =
	(case ident of
	 Nothing -> Fun.id
	 Just (Ident i) ->
		B.AddCustomAttribute "id" $
		B.String $ TL.unpack i) .
	case classes of
	 [] -> Fun.id
	 _ ->
		B.AddCustomAttribute "class" $
		B.String $ TL.unpack $ TL.unwords classes