module Rakka.Wiki.Formatter
    ( formatWikiBlocks
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowList
import           Control.Arrow.ArrowTree
import           Data.Char
import           Data.List
import           Data.Maybe
import           Network.URI
import           Rakka.Page
import           Rakka.Wiki
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.DOM.TypeDefs


formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
formatWikiBlocks
    = proc (baseURI, blocks)
    -> do block   <- arrL id     -< blocks
          tree    <- formatBlock -< (baseURI, block)
          attachXHtmlNs -< tree


formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
formatBlock 
    = proc (baseURI, block)
    -> case block of
         Heading level text
             -> formatHeading -< (level, text)

         HorizontalLine
             -> eelem "hr" -< ()

         List list
             -> formatListElement -< (baseURI, list)

         DefinitionList list
             -> formatDefinitionList -< (baseURI, list)

         Preformatted inlines
             -> formatPreformatted -< (baseURI, inlines)
                
         Paragraph inlines
             -> formatParagraph -< (baseURI, inlines)

         Div attrs contents
             -> formatElem "div" -< (baseURI, attrs, contents)

         EmptyBlock
             -> none -< ()
    where
      formatElem :: (ArrowXml a, ArrowChoice a) =>
                    String
                 -> a (URI, [Attribute], [BlockElement]) XmlTree
      formatElem name
          = proc (baseURI, attrs, contents)
          -> ( eelem name
               += ( arrL (fst . snd)
                       >>>
                       attrFromPair
                  )
               += ( (arr fst &&& arrL (snd . snd))
                    >>>
                    formatBlock
                  )
             ) -< (baseURI, (attrs, contents))


formatHeading :: ArrowXml a => a (Int, String) XmlTree
formatHeading 
    = proc (level, text)
    -> mkelem ("h" ++ show level)
       [ sattr "id" text ]
       [ txt text        ] -<< ()


formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
formatListElement 
    = proc (baseURI, list)
    -> let tag = case listType list of
                   Bullet   -> "ul"
                   Numbered -> "ol"
       in
         ( eelem tag
           += ( (constA baseURI &&& constL (listItems list))
                >>>
                formatListItem
              )
         ) -<< ()
      where
        formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree
        formatListItem 
            = proc (baseURI, item)
            -> eelem "li"
               += ( (arr fst &&& arrL snd)
                    >>>
                    formatListItem'
                  ) -< (baseURI, item)

        formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree
        formatListItem' 
            = proc (baseURI, x)
            -> case x of
                 Left  nestedList -> formatListElement -< (baseURI, nestedList)
                 Right inline     -> formatInline      -< (baseURI, inline    )


formatDefinitionList :: (ArrowXml a, ArrowChoice a) => a (URI, [Definition]) XmlTree
formatDefinitionList 
    = proc (baseURI, list)
    -> ( eelem "dl"
         += ( (arr fst &&& arrL snd)
              >>>
              formatDefinition
            )
       ) -< (baseURI, list)
    where
      formatDefinition :: (ArrowXml a, ArrowChoice a) => a (URI, Definition) XmlTree
      formatDefinition 
          = proc (baseURI, def)
          -> ( eelem "dt"
               += ( (arr fst &&& arrL (defTerm . snd))
                    >>>
                    formatInline
                  )
               <+>
               eelem "dd"
               += ( (arr fst &&& arrL (defDesc . snd))
                    >>>
                    formatInline
                  )
             ) -< (baseURI, def)


formatPreformatted :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
formatPreformatted
    = eelem "pre"
      += ( (arr fst &&& arrL snd)
           >>>
           formatInline
         )


formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
formatParagraph 
    = eelem "p"
      += ( (arr fst &&& arrL snd)
           >>>
           formatInline
         )


formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
formatInline 
    = proc (baseURI, i)
    -> case i of
         Text text
             -> mkText -< text

         Italic contents
             -> formatElem "i" -< (baseURI, [], contents)

         Bold contents
             -> formatElem "b" -< (baseURI, [], contents)

         link@(PageLink _ _ _)
             -> formatPageLink -< (baseURI, link)

         link@(ExternalLink _ _)
             -> formatExternalLink -< link

         LineBreak attrs
             -> formatElem "br" -< (baseURI, attrs, [])

         Span attrs contents
             -> formatElem "span" -< (baseURI, attrs, contents)

         Image attrs
             -> formatElem "img" -< (baseURI, attrs, [])

         Anchor attrs contents
             -> formatElem "a" -< (baseURI, attrs, contents)

         EmptyInline
             -> none -< ()
    where
      formatElem :: (ArrowXml a, ArrowChoice a) =>
                    String
                 -> a (URI, [Attribute], [InlineElement]) XmlTree
      formatElem name
          = proc (baseURI, attrs, contents)
          -> ( eelem name
               += ( arrL (fst . snd)
                       >>>
                       attrFromPair
                  )
               += ( (arr fst &&& arrL (snd . snd))
                    >>>
                    formatInline
                  )
             ) -< (baseURI, (attrs, contents))


attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
attrFromPair = proc (name, value)
             -> attr name (txt value) -<< ()


formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
formatPageLink 
    = proc (baseURI, PageLink page fragment text)
    -> let uri    = case (page, fragment) of
                      (Just  x, Just  y) -> mkPageFragmentURI baseURI (fix x) y
                      (Just  x, Nothing) -> mkPageURI baseURI (fix x)
                      (Nothing, Just  y) -> nullURI { uriFragment = ('#':y) }
           fix    = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
           href   = uriToString id uri ""
           dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
           label  = fromMaybe dLabel text
       in
         ( eelem "a"
           += attr "href" (arr fst >>> mkText)
           += (arr snd >>> mkText)
         ) -< (href, label)


formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
formatExternalLink 
    = proc (ExternalLink uri text)
    -> let href  = uriToString id uri ""
           label = fromMaybe href text
       in
         ( eelem "a"
           += attr "href" (arr fst >>> mkText)
           += (arr snd >>> mkText)
         ) -< (href, label)


attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
attachXHtmlNs = processBottomUp (changeQName attach')
    where
      attach' :: QName -> QName
      attach' qn = qn {
                     namePrefix   = "xhtml"
                   , namespaceUri = "http://www.w3.org/1999/xhtml"
                   }