Implemented the outline command

[Rakka.git] / Rakka / Wiki / Engine.hs

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 5aa5db4ac90e5d81a13ac28eedd086e90a585766..ffaab2f4edf28a9a41b19be39b223be3999d4e8f 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -1,19 +1,23 @@
 module Rakka.Wiki.Engine
     ( formatPage
+    , formatSubPage
     )
     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
@@ -24,37 +28,108 @@ formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
            -> a Page XmlTree
 formatPage env
     = proc page
-    -> do tree <- case pageType page of
-                    MIMEType "text" "x-rakka" _
-                        -> formatWikiPage env -< page
-          attachXHtmlNs -< tree
+    -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+          interpTable     <- getInterpTableA env -< ()
+          wiki            <- wikifyPage env -< (interpTable, page)
+          xs              <- interpretCommandsA env -< (interpTable, (pageName page, (Just wiki, wiki)))
+          formatWikiBlocks -< (baseURI, xs)
 
 
-formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
-                  Environment
-               -> a Page XmlTree
-formatWikiPage env
-    = proc page
-    -> do let source = decodeLazy UTF8 (pageContent page)
-          case parse wikiPage "" source of
-            Left  err
-                -> formatParseError -< err
+formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+                 Environment
+              -> a (PageName, (Maybe Page, Page)) XmlTree
+formatSubPage env
+    = proc (mainPageName, (mainPage, subPage))
+    -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+          interpTable     <- getInterpTableA env -< ()
+          mainWiki        <- case mainPage of
+                               Just page
+                                   -> do wiki <- wikifyPage env -< (interpTable, page)
+                                         returnA -< Just wiki
+                               Nothing
+                                   -> returnA -< Nothing
+          subWiki        <- wikifyPage env -< (interpTable, subPage)
+          xs             <- interpretCommandsA env -< (interpTable, (mainPageName, (mainWiki, subWiki)))
+          formatWikiBlocks -< (baseURI, xs)
+
+
+wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+                 Environment
+              -> a (InterpTable, Page) WikiPage
+wikifyPage env
+    = proc (interpTable, page)
+    -> case pageType page of
+         MIMEType "text" "x-rakka" _
+             -> do let source = decodeLazy UTF8 (pageContent page)
+                       parser = wikiPage (tableToFunc interpTable)
+
+                   case parse parser "" source of
+                     Left  err
+                         -> wikifyParseError -< err
 
-            Right elems
-                -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
-                      formatWikiElements -< (baseURI, elems)
+                     Right xs
+                         -> returnA -< xs
+    where
+      tableToFunc :: InterpTable -> String -> Maybe CommandType
+      tableToFunc table name
+          = fmap commandType (M.lookup name table)
 
 
-formatParseError :: ArrowXml a => a ParseError XmlTree
-formatParseError 
-    = proc err -> (eelem "pre" += txt (show err)) -<< ()
+interpretCommandsA :: ArrowIO a =>
+                      Environment
+                   -> a (InterpTable, (PageName, (Maybe WikiPage, WikiPage))) WikiPage
+interpretCommandsA = arrIO4 . interpretCommands
 
 
-attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
-attachXHtmlNs = processBottomUp (changeQName attach')
+interpretCommands :: Environment -> InterpTable -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage
+interpretCommands _   _     _    _        []         = return []
+interpretCommands env table name mainTree targetTree
+    = everywhereM' (mkM interpBlockCmd) targetTree
+      >>=
+      everywhereM' (mkM interpInlineCmd)
     where
-      attach' :: QName -> QName
-      attach' qn = qn {
-                     namePrefix   = "xhtml"
-                   , namespaceUri = "http://www.w3.org/1999/xhtml"
-                   }
+      ctx :: InterpreterContext
+      ctx = InterpreterContext {
+              ctxPageName   = name
+            , ctxMainTree   = mainTree
+            , ctxTargetTree = targetTree
+            , 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)
+
+
+wikifyParseError :: ArrowXml a => a ParseError WikiPage
+wikifyParseError 
+    = proc err -> returnA -< [Preformatted [Text (show err)]]