Farewell the dream of plug-in system... It's way too hard to implement nicely. Many...

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

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index f0de8fb7b078ac6ae14ded434c47b0399ffd2a75..2b751d4a47db96bc49bc23e0ef02f0d54e2d2427 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -6,7 +6,6 @@ module Rakka.Wiki.Engine
 
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
-import           Control.Arrow.ArrowTree
 import           Data.Encoding
 import           Data.Encoding.UTF8
 import           Data.Generics
@@ -29,67 +28,72 @@ formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
            -> 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
+    -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+          wiki            <- wikifyPage env -< page
+          xs              <- interpretCommandsA env -< (pageName page, (Just wiki, wiki))
+          formatWikiBlocks -< (baseURI, xs)
 
 
 formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                  Environment
-              -> a (Page, Page) XmlTree
+              -> a (PageName, (Maybe 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)
+    = proc (mainPageName, (mainPage, subPage))
     -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
-          interpTable     <- getInterpTableA env -< ()
-
-          let parser = wikiPage (tableToFunc interpTable)
+          mainWiki        <- case mainPage of
+                               Just page
+                                   -> do wiki <- wikifyPage env -< page
+                                         returnA -< Just wiki
+                               Nothing
+                                   -> returnA -< Nothing
+          subWiki        <- wikifyPage env -< subPage
+          xs             <- interpretCommandsA env -< (mainPageName, (mainWiki, subWiki))
+          formatWikiBlocks -< (baseURI, xs)
+
+
+wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+                 Environment
+              -> a Page WikiPage
+wikifyPage env
+    = proc page
+    -> case pageType page of
+         MIMEType "text" "x-rakka" _
+             -> do let source = decodeLazy UTF8 (pageContent page)
+                       parser = wikiPage tableToFunc
 
-          case parse parser "" source of
-            Left  err
-                -> formatParseError -< err
+                   case parse parser "" source of
+                     Left  err
+                         -> wikifyParseError -< err
 
-            Right blocks
-                -> do xs <- interpretCommandsA env -< (interpTable, (page, blocks))
-                      formatWikiBlocks -< (baseURI, xs)
+                     Right xs
+                         -> returnA -< xs
     where
-      tableToFunc :: InterpTable -> String -> Maybe CommandType
-      tableToFunc table name
-          = fmap commandType (M.lookup name table)
+      tableToFunc :: String -> Maybe CommandType
+      tableToFunc name
+          = fmap commandType (M.lookup name (envInterpTable env))
 
 
 interpretCommandsA :: ArrowIO a =>
                       Environment
-                   -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage
+                   -> a (PageName, (Maybe WikiPage, 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)
+interpretCommands :: Environment -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage
+interpretCommands _   _    _        []         = return []
+interpretCommands env name mainTree targetTree
+    = everywhereM' (mkM interpBlockCmd) targetTree
+      >>=
+      everywhereM' (mkM interpInlineCmd)
     where
       ctx :: InterpreterContext
       ctx = InterpreterContext {
-                  ctxPage    = page
-                , ctxTree    = blocks
-                , ctxStorage = envStorage env
-                , ctxSysConf = envSysConf env
-                }
+              ctxPageName   = name
+            , ctxMainTree   = mainTree
+            , ctxTargetTree = targetTree
+            , ctxStorage    = envStorage env
+            , ctxSysConf    = envSysConf env
+            }
 
       interpBlockCmd :: BlockElement -> IO BlockElement
       interpBlockCmd (BlockCmd cmd) = interpBlockCmd' cmd
@@ -97,7 +101,7 @@ interpretCommands env table page blocks = everywhereM' (mkM interpBlockCmd) bloc
 
       interpBlockCmd' :: BlockCommand -> IO BlockElement
       interpBlockCmd' cmd
-          = case M.lookup (bCmdName cmd) table of
+          = case M.lookup (bCmdName cmd) (envInterpTable env) of
               Nothing
                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 
@@ -111,7 +115,7 @@ interpretCommands env table page blocks = everywhereM' (mkM interpBlockCmd) bloc
 
       interpInlineCmd' :: InlineCommand -> IO InlineElement
       interpInlineCmd' cmd
-          = case M.lookup (iCmdName cmd) table of
+          = case M.lookup (iCmdName cmd) (envInterpTable env) of
               Nothing
                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 
@@ -124,16 +128,7 @@ 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"
-                   }
+wikifyParseError :: ArrowXml a => a ParseError WikiPage
+wikifyParseError 
+    = proc err -> returnA -< [Div [("class", "error")]
+                              [ Preformatted [Text (show err)] ]]