module Rakka.Wiki.Engine
    ( InterpTable
    , formatEntirePage
    , formatUnexistentPage
    , makeDraft
    )
    where

import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowList
import           Data.Encoding
import           Data.Encoding.UTF8
import           Data.Generics
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Maybe
import           Network.HTTP.Lucu
import           Network.URI
import           Rakka.Page
import           Rakka.Storage
import           Rakka.SystemConfig
import           Rakka.Utils
import           Rakka.Wiki
import           Rakka.Wiki.Parser
import           Rakka.Wiki.Formatter
import           Rakka.Wiki.Interpreter
import           Text.HyperEstraier hiding (getText)
import           Text.ParserCombinators.Parsec
import           Text.XML.HXT.Arrow.Namespace
import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.DOM.TypeDefs


type InterpTable = Map String Interpreter


formatEntirePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                    Storage
                 -> SystemConfig
                 -> InterpTable
                 -> a Page XmlTree
formatEntirePage sto sysConf interpTable
    = proc page
    -> do SiteName   siteName <- getSysConfA sysConf -< ()
          BaseURI    baseURI  <- getSysConfA sysConf -< ()
          StyleSheet cssName  <- getSysConfA sysConf -< ()

          Just pageTitle    <- getPageA sto -< ("PageTitle"    , Nothing)
          Just leftSideBar  <- getPageA sto -< ("SideBar/Left" , Nothing)
          Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing)

          tree <- ( eelem "/"
                    += ( eelem "page"
                         += sattr "site"       siteName
                         += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
                         += sattr "name"       (pageName page)
                         += sattr "type"       (show $ pageType page)
                         += ( case pageLanguage page of
                                Just x -> sattr "lang" x
                                _      -> none
                            )
                         += ( case pageFileName page of
                                Just x -> sattr "fileName" x
                                _      -> none
                            )
                         += ( case pageType page of
                                MIMEType "text" "css" _
                                    -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
                                _   -> none
                            )
                         += ( case pageType page of
                                MIMEType "text" "x-rakka" _
                                    -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
                                _   -> none
                            )
                         += sattr "isLocked" (yesOrNo $ pageIsLocked page)
                         += sattr "isBoring" (yesOrNo $ pageIsBoring page)
                         += sattr "isBinary" (yesOrNo $ pageIsBinary page)
                         += sattr "revision" (show $ pageRevision page)
                         += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)

                         += ( case pageSummary page of
                                Nothing -> none
                                Just s  -> eelem "summary" += txt s
                            )

                         += ( if M.null (pageOtherLang page) then
                                  none
                              else
                                  selem "otherLang"
                                            [ eelem "link"
                                              += sattr "lang" lang
                                              += sattr "page" page
                                                  | (lang, page) <- M.toList (pageOtherLang page) ]
                            )
                         += ( eelem "pageTitle"
                              += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
                                   >>>
                                   formatSubPage sto sysConf interpTable
                                 )
                            )
                         += ( eelem "sideBar"
                              += ( eelem "left"
                                   += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
                                        >>>
                                        formatSubPage sto sysConf interpTable
                                      )
                                 )
                              += ( eelem "right"
                                   += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
                                        >>>
                                        formatSubPage sto sysConf interpTable
                                      )
                                 )
                            )
                         += ( eelem "body"
                              += (constA page >>> formatMainPage sto sysConf interpTable)
                            )
                         >>>
                         uniqueNamespacesFromDeclAndQNames
                       )
                  ) -<< ()
          returnA -< tree


formatUnexistentPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                        Storage
                     -> SystemConfig
                     -> InterpTable
                     -> a PageName XmlTree
formatUnexistentPage sto sysConf interpTable
    = proc name
    -> do SiteName   siteName <- getSysConfA sysConf -< ()
          BaseURI    baseURI  <- getSysConfA sysConf -< ()
          StyleSheet cssName  <- getSysConfA sysConf -< ()

          Just pageTitle    <- getPageA sto -< ("PageTitle"    , Nothing)
          Just leftSideBar  <- getPageA sto -< ("SideBar/Left" , Nothing)
          Just rightSideBar <- getPageA sto -< ("SideBar/Right", Nothing)

          tree <- ( eelem "/"
                    += ( eelem "pageNotFound"
                         += sattr "site"       siteName
                         += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
                         += sattr "name"       name
                         
                         += ( eelem "pageTitle"
                              += ( (constA name &&& constA Nothing &&& constA pageTitle)
                                   >>>
                                   formatSubPage sto sysConf interpTable
                                 )
                            )
                         += ( eelem "sideBar"
                              += ( eelem "left"
                                   += ( (constA name &&& constA Nothing &&& constA leftSideBar)
                                        >>>
                                        formatSubPage sto sysConf interpTable
                                      )
                                 )
                              += ( eelem "right"
                                   += ( (constA name &&& constA Nothing &&& constA rightSideBar)
                                        >>>
                                        formatSubPage sto sysConf interpTable
                                      )
                                 )
                            )
                         >>>
                         uniqueNamespacesFromDeclAndQNames
                       )
                  ) -<< ()
          returnA -< tree


formatMainPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                  Storage
               -> SystemConfig
               -> InterpTable
               -> a Page XmlTree
formatMainPage sto sysConf interpTable
    = proc page
    -> do BaseURI baseURI <- getSysConfA sysConf -< ()
          wiki            <- arr2 wikifyPage -< (interpTable, page)
          xs              <- interpretCommandsA sto sysConf interpTable
                             -< (pageName page, Just (page, wiki), wiki)
          formatWikiBlocks -< (baseURI, xs)


formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                 Storage
              -> SystemConfig
              -> InterpTable
              -> a (PageName, (Maybe Page, Page)) XmlTree
formatSubPage sto sysConf interpTable
    = proc (mainPageName, (mainPage, subPage))
    -> do BaseURI baseURI <- getSysConfA sysConf -< ()
          mainWiki        <- case mainPage of
                               Just page
                                   -> do wiki <- arr2 wikifyPage -< (interpTable, page)
                                         returnA -< Just (page, wiki)
                               Nothing
                                   -> returnA -< Nothing
          subWiki        <- arr2 wikifyPage -< (interpTable, subPage)
          xs             <- interpretCommandsA sto sysConf interpTable
                            -< (mainPageName, mainWiki, subWiki)
          formatWikiBlocks -< (baseURI, xs)


wikifyPage :: InterpTable -> Page -> WikiPage
wikifyPage interpTable page
    = case pageType page of
        MIMEType "text" "x-rakka" _
            -> let source = decodeLazy UTF8 (pageContent page)
                   parser = wikiPage tableToFunc
               in
                 case parse parser "" source of
                   Left err -> wikifyParseError err
                   Right xs -> xs

        MIMEType "image" _ _
            -> [ Paragraph [ Image (pageName page) Nothing ] ]

        _   -> if pageIsBinary page then
                   -- object へのリンクのみ
                   [ Paragraph [ ObjectLink (pageName page) (Just $ pageFileName' page) ] ]
               else
                   -- pre
                   let text = decodeLazy UTF8 (pageContent page)
                   in
                     [ Preformatted [ Text text ] ]
    where
      tableToFunc :: String -> Maybe CommandType
      tableToFunc name
          = fmap commandType (M.lookup name interpTable)


interpretCommandsA :: (ArrowIO a, ArrowApply a) =>
                      Storage
                   -> SystemConfig
                   -> InterpTable
                   -> a (PageName, Maybe (Page, WikiPage), WikiPage) WikiPage
interpretCommandsA sto sysConf interpTable
    = proc (name, mainPageAndTree, targetTree)
    -> arrIO0 (interpretCommands sto sysConf interpTable name mainPageAndTree targetTree) 
       -<< ()


interpretCommands :: Storage
                  -> SystemConfig
                  -> InterpTable
                  -> PageName
                  -> Maybe (Page, WikiPage)
                  -> WikiPage
                  -> IO WikiPage
interpretCommands sto sysConf interpTable name mainPageAndTree targetTree
    = everywhereM' (mkM interpBlockCmd) targetTree
      >>=
      everywhereM' (mkM interpInlineCmd)
    where
      ctx :: InterpreterContext
      ctx = InterpreterContext {
              ctxPageName   = name
            , ctxMainPage   = fmap fst mainPageAndTree
            , ctxMainTree   = fmap snd mainPageAndTree
            , ctxTargetTree = targetTree
            , ctxStorage    = sto
            , ctxSysConf    = sysConf
            }

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

      interpBlockCmd' :: BlockCommand -> IO BlockElement
      interpBlockCmd' cmd
          = case M.lookup (bCmdName cmd) interpTable 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) interpTable of
              Nothing
                  -> fail ("no such interpreter: " ++ iCmdName cmd)

              Just interp
                  -> iciInterpret interp ctx cmd


makeDraft :: InterpTable -> Page -> IO Document
makeDraft interpTable page
    = do doc <- newDocument

         setURI       doc                  $ Just $ mkRakkaURI $ pageName page
         setAttribute doc "@title"         $ Just $ pageName page
         setAttribute doc "@lang"          $ pageLanguage page
         setAttribute doc "@type"          $ Just $ show $ pageType page
         setAttribute doc "@mdate"         $ Just $ formatW3CDateTime $ pageLastMod page
         setAttribute doc "rakka:fileName" $ pageFileName page
         setAttribute doc "rakka:isLocked" $ Just $ yesOrNo $ pageIsLocked page
         setAttribute doc "rakka:isBoring" $ Just $ yesOrNo $ pageIsBoring page
         setAttribute doc "rakka:isBinary" $ Just $ yesOrNo $ pageIsBinary page
         setAttribute doc "rakka:revision" $ Just $ show $ pageRevision page

         case pageType page of
            MIMEType "text" "css" _
                -> setAttribute doc "rakka:isTheme" $ Just $ yesOrNo $ pageIsTheme page
            MIMEType "text" "x-rakka" _
                -> setAttribute doc "rakka:isFeed"  $ Just $ yesOrNo $ pageIsFeed page
            _   -> return ()

         case pageSummary page of
           Nothing -> return ()
           Just s  -> addHiddenText doc s

         -- otherLang はリンク先ページ名を hidden text で入れる。
         sequence_ [ addHiddenText doc x
                         | (_, x) <- M.toList (pageOtherLang page) ]

         -- wikify して興味のある部分を addText する。
         let wikiPage = wikifyPage interpTable page
         everywhereM' (mkM (addBlockText  doc)) wikiPage
         everywhereM' (mkM (addInlineText doc)) wikiPage

         return doc
    where
      addBlockText :: Document -> BlockElement -> IO BlockElement
      addBlockText doc b
          = do case b of
                 Heading _ text
                     -> addText doc text
                 _   -> return ()
               return b

      addInlineText :: Document -> InlineElement -> IO InlineElement
      addInlineText doc i
          = do case i of
                 Text text
                     -> addText doc text
                 ObjectLink page Nothing
                     -> addText doc page
                 ObjectLink page (Just text)
                     -> do addHiddenText doc page
                           addText doc text
                 PageLink page fragment Nothing
                     -> addText doc (fromMaybe "" page ++
                                     fromMaybe "" fragment)
                 PageLink page fragment (Just text)
                     -> do addHiddenText doc (fromMaybe "" page ++
                                              fromMaybe "" fragment)
                           addText doc text
                 ExternalLink uri Nothing
                     -> addText doc (uriToString id uri "")
                 ExternalLink uri (Just text)
                     -> do addHiddenText doc (uriToString id uri "")
                           addText doc text
                 _   -> return ()
               return i


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


wikifyParseError :: ParseError -> WikiPage
wikifyParseError err
    = [Div [("class", "error")]
               [ Preformatted [Text (show err)] ]]