module Rakka.Wiki.Engine
    ( formatPage
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowTree
import           Data.Encoding
import           Data.Encoding.UTF8
import           Data.Generics
import qualified Data.Map as M
import           Network.HTTP.Lucu
import           Rakka.Environment
import           Rakka.Page
import           Rakka.SystemConfig
import           Rakka.Wiki
import           Rakka.Wiki.Parser
import           Rakka.Wiki.Formatter
import           Rakka.Wiki.Interpreter
import           Text.ParserCombinators.Parsec
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.DOM.TypeDefs


formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
              Environment
           -> a Page XmlTree
formatPage env
    = proc page
    -> do tree <- case pageType page of
                    MIMEType "text" "x-rakka" _
                        -> do let source = decodeLazy UTF8 (pageContent page)
                              formatWikiPage env -< (Just page, source)
          attachXHtmlNs -< tree


formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                  Environment
               -> a (Maybe Page, String) XmlTree
formatWikiPage env
    = proc (page, source)
    -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
          interpTable     <- getInterpTableA env -< ()

          let parser = wikiPage (tableToFunc interpTable)

          case parse parser "" source of
            Left  err
                -> formatParseError -< err

            Right blocks
                -> do xs <- interpretCommandsA env -< (interpTable, (page, blocks))
                      formatWikiBlocks -< (baseURI, xs)
    where
      tableToFunc :: InterpTable -> String -> Maybe CommandType
      tableToFunc table name
          = fmap commandType (M.lookup name table)


interpretCommandsA :: ArrowIO a =>
                      Environment
                   -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage
interpretCommandsA = arrIO3 . interpretCommands


interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage
interpretCommands _   _     _    []     = return []
interpretCommands env table page blocks = everywhereM' (mkM interpBlockCmd) blocks
                                          >>=
                                          everywhereM' (mkM interpInlineCmd)
    where
      ctx :: InterpreterContext
      ctx = InterpreterContext {
                  ctxPage    = page
                , ctxTree    = blocks
                , ctxStorage = envStorage env
                , ctxSysConf = envSysConf env
                }

      interpBlockCmd :: BlockElement -> IO BlockElement
      interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
      interpBlockCmd others         = return others

      interpBlockCmd' :: BlockCommand -> IO BlockElement
      interpBlockCmd' cmd
          = case M.lookup (bCmdName cmd) table of
              Nothing
                  -> fail ("no such interpreter: " ++ bCmdName cmd)

              Just interp
                  -> bciInterpret interp ctx cmd


      interpInlineCmd :: InlineElement -> IO InlineElement
      interpInlineCmd (InlineCmd cmd) = interpInlineCmd' cmd
      interpInlineCmd others          = return others

      interpInlineCmd' :: InlineCommand -> IO InlineElement
      interpInlineCmd' cmd
          = case M.lookup (iCmdName cmd) table of
              Nothing
                  -> fail ("no such interpreter: " ++ iCmdName cmd)

              Just interp
                  -> iciInterpret interp ctx cmd


-- Perform monadic transformation in top-down order.
everywhereM' :: Monad m => GenericM m -> GenericM m
everywhereM' f x = f x >>= gmapM (everywhereM' f)


formatParseError :: ArrowXml a => a ParseError XmlTree
formatParseError 
    = proc err -> (eelem "pre" += txt (show err)) -<< ()


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"
                   }