Implemented sidebars

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

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 56a7adb97459857af218590f925968dc39be2a46..f0de8fb7b078ac6ae14ded434c47b0399ffd2a75 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -1,39 +1,127 @@
 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
 
 
-formatPage :: (ArrowXml a, ArrowChoice a) =>
-              a Page XmlTree
-formatPage
+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" _
-                        -> formatWikiPage -< page
+                        -> do let source = decodeLazy UTF8 (pageContent page)
+                              formatWikiPage env -< (Just page, source)
           attachXHtmlNs -< tree
 
 
-formatWikiPage :: (ArrowXml a, ArrowChoice a) =>
-                  a Page XmlTree
-formatWikiPage
-    = proc page
-    -> do let source = decodeLazy UTF8 (pageContent page)
-          case parse wikiPage "" source of
-            Left  err   -> formatParseError   -< err
-            Right elems -> formatWikiElements -< elems
+formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+                 Environment
+              -> a (Page, Page) XmlTree
+formatSubPage env
+    = proc (mainPage, subPage)
+    -> do tree <- case pageType subPage of
+                    MIMEType "text" "x-rakka" _
+                        -> do let source = decodeLazy UTF8 (pageContent subPage)
+                              formatWikiPage env -< (Just mainPage, 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