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 65009751dde7694c12a52fd4b678f5e5d20261ea..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,49 +66,49 @@ 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
-      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 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 }
-
-      interpInline :: InlineElement -> IO InlineElement
-      interpInline (Italic    xs ) = mapM interpInline xs >>= return . Italic
-      interpInline (Bold      xs ) = mapM interpInline xs >>= return . Bold
-      interpInline (InlineCmd cmd) = interpInlineCmd cmd
-      interpInline others          = return others
-
-      interpInlineCmd :: InlineCommand -> IO InlineElement
-      interpInlineCmd cmd
+      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 cmd page (envStorage env) (envSysConf env)
-                     >>=
-                     interpInline
+                  -> 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