module Rakka.Wiki.Formatter
    ( formatWikiElements
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowList
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


-- 複數の Inline を一つに纏める
packParagraph :: [WikiElement] -> [Either BlockElement [InlineElement]]
packParagraph elems = map pack grp
    where
      grp :: [[WikiElement]]
      grp = groupBy criteria elems

      criteria :: WikiElement -> WikiElement -> Bool
      criteria (Inline _) (Inline _) = True
      criteria _ _                   = False

      pack :: [WikiElement] -> Either BlockElement [InlineElement]
      pack (Block b : []) = Left b
      pack xs             = Right [ case x of
                                      Inline i -> i | x <- xs ]
                                                       

formatWikiElements :: (ArrowXml a, ArrowChoice a) => a (URI, [WikiElement]) XmlTree
formatWikiElements
    = proc (baseURI, elems)
    -> do chunk <- arrL id -< packParagraph elems
          case chunk of
            Left  x  -> formatBlock     -< x
            Right xs -> formatParagraph -< (baseURI, xs)


formatBlock :: (ArrowXml a, ArrowChoice a) => a BlockElement XmlTree
formatBlock 
    = proc b
    -> case b of
         Heading level text
             -> formatHeading -< (level, text)
         EmptyLine
             -> none -< ()


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


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

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


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 x y
                      (Just  x, Nothing) -> mkPageURI baseURI x
                      (Nothing, Just  y) -> nullURI { uriFragment = ('#':y) }
           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)