X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FWiki%2FEngine.hs;h=f0de8fb7b078ac6ae14ded434c47b0399ffd2a75;hb=dcfffa578c5dd6647a5be7d2074488a520dfcf2d;hp=3300181bab098ea913c76240864d0bbc5483d81f;hpb=4608e8de5f9d72f12055494467283b4dea2faeb5;p=Rakka.git

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 3300181..f0de8fb 100644
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -1,5 +1,6 @@
 module Rakka.Wiki.Engine
     ( formatPage
+    , formatSubPage
     )
     where
 
@@ -8,6 +9,7 @@ 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
@@ -34,6 +36,18 @@ formatPage env
           attachXHtmlNs -< tree
 
 
+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
@@ -65,7 +79,9 @@ interpretCommandsA = arrIO3 . interpretCommands
 
 interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage
 interpretCommands _   _     _    []     = return []
-interpretCommands env table page blocks = mapM interpBlock blocks
+interpretCommands env table page blocks = everywhereM' (mkM interpBlockCmd) blocks
+                                          >>=
+                                          everywhereM' (mkM interpInlineCmd)
     where
       ctx :: InterpreterContext
       ctx = InterpreterContext {
@@ -75,61 +91,37 @@ interpretCommands env table page blocks = mapM interpBlock blocks
                 , ctxSysConf = envSysConf env
                 }
 
-      interpBlock :: BlockElement -> IO BlockElement
-      interpBlock (List list)           = interpList list >>= return . List
-      interpBlock (DefinitionList defs) = mapM interpDefinition defs >>= return . DefinitionList
-      interpBlock (Preformatted xs)     = mapM interpInline xs >>= return . Preformatted
-      interpBlock (Paragraph xs)        = mapM interpInline xs >>= return . Paragraph
-      interpBlock (Div attrs xs)        = mapM interpBlock xs >>= return . Div attrs
-      interpBlock (BlockCmd cmd)        = interpBlockCmd cmd
-      interpBlock others                = return others
-
-      interpList :: ListElement -> IO ListElement
-      interpList list = do items <- mapM interpListItem (listItems list)
-                           return $ list { listItems = items }
-
-      interpListItem :: ListItem -> IO ListItem
-      interpListItem []                  = return []
-      interpListItem ((Left  nested):xs) = do x  <- interpList nested >>= return . Left
-                                              xs <- interpListItem xs
-                                              return (x:xs)
-      interpListItem ((Right inline):xs) = do x  <- interpInline inline >>= return . Right
-                                              xs <- interpListItem xs
-                                              return (x:xs)
-
-      interpDefinition :: Definition -> IO Definition
-      interpDefinition def = do term <- mapM interpInline (defTerm def)
-                                desc <- mapM interpInline (defDesc def)
-                                return $ def { defTerm = term, defDesc = desc }
-
-      interpBlockCmd :: BlockCommand -> IO BlockElement
-      interpBlockCmd cmd
+      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
-                     >>=
-                     interpBlock
-
-      interpInline :: InlineElement -> IO InlineElement
-      interpInline (Italic xs)     = mapM interpInline xs >>= return . Italic
-      interpInline (Bold xs )      = mapM interpInline xs >>= return . Bold
-      interpInline (Span attrs xs) = mapM interpInline xs >>= return . Span attrs
-      interpInline (InlineCmd cmd) = interpInlineCmd cmd
-      interpInline others          = return others
-
-      interpInlineCmd :: InlineCommand -> IO InlineElement
-      interpInlineCmd 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
-                     >>=
-                     interpInline
+
+
+-- 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