The experimental code worked like a magic. I can't believe that.

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

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 3300181bab098ea913c76240864d0bbc5483d81f..1da0d0efc12439263a67aaeb817970afc41d1fd2 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -8,6 +8,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
@@ -65,7 +66,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 +78,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