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

darcs-hash:20071021091812-62b54-0b27a1ebc4598dec542d0d38a1ad42e208f6df85.gz

diff --git a/Rakka.cabal b/Rakka.cabal
index 859d3054ad7c64c91ef4afbad073da4318f9af4b..7380ae491857cadcf258de604fb8dfa424bc527d 100644 (file)
--- a/Rakka.cabal
+++ b/Rakka.cabal
@@ -23,7 +23,7 @@ Tested-With:
 Extensions:
     Arrows
 GHC-Options:
-    -fwarn-unused-imports
+    -fwarn-unused-imports -fglasgow-exts
 Build-Depends:
     Crypto, HUnit, HsSVN, Lucu, base, encoding, filepath, hxt, mtl,
     network, parsec, unix
@@ -63,7 +63,7 @@ Other-Modules:
 Extensions:
     Arrows
 GHC-Options:
-    -fwarn-unused-imports
+    -fwarn-unused-imports -fglasgow-exts
 
 
 Executable:
@@ -73,4 +73,6 @@ Main-Is:
 Hs-Source-Dirs:
     tests
 Other-Modules:
-    WikiParserTest
\ No newline at end of file
+    WikiParserTest
+GHC-Options:
+    -fwarn-unused-imports -fglasgow-exts
\ No newline at end of file

diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs
index f0e38fedd47994f629efdd6ae1f2dbe74ac4b784..96231a46c72174bc33c7df3733e8c9457e230b09 100644 (file)
--- a/Rakka/Wiki.hs
+++ b/Rakka/Wiki.hs
@@ -16,6 +16,7 @@ module Rakka.Wiki
     )
     where
 
+import           Data.Generics
 import           Rakka.Page
 
 
@@ -34,7 +35,7 @@ data BlockElement
     | Paragraph ![InlineElement]
     | Div ![Attribute] ![BlockElement]
     | BlockCmd !BlockCommand
-    deriving (Eq, Show)
+    deriving (Eq, Show, Typeable, Data)
 
 
 data InlineElement
@@ -51,7 +52,7 @@ data InlineElement
     | Image ![Attribute]
     | Anchor ![Attribute] ![InlineElement]
     | InlineCmd !InlineCommand
-    deriving (Eq, Show)
+    deriving (Eq, Show, Typeable, Data)
 
 
 data ListElement
@@ -59,13 +60,13 @@ data ListElement
         listType  :: !ListType
       , listItems :: ![ListItem]
       }
-    deriving (Eq, Show)
+    deriving (Eq, Show, Typeable, Data)
 
 
 data ListType
     = Bullet
     | Numbered
-    deriving (Eq, Show)
+    deriving (Eq, Show, Typeable, Data)
 
 
 type ListItem = [Either ListElement InlineElement]
@@ -76,12 +77,13 @@ data Definition
         defTerm :: ![InlineElement]
       , defDesc :: ![InlineElement]
       }
-    deriving (Eq, Show)
+    deriving (Eq, Show, Typeable, Data)
 
 
 data CommandType
     = InlineCommandType
     | BlockCommandType
+    deriving (Eq, Show)
 
 
 type Attribute = (String, String)
@@ -93,7 +95,7 @@ data BlockCommand
       , bCmdAttributes :: ![Attribute]
       , bCmdContents   :: ![BlockElement]
       }
-    deriving (Eq, Show)
+    deriving (Eq, Show, Typeable, Data)
 
 
 data InlineCommand
@@ -102,4 +104,4 @@ data InlineCommand
       , iCmdAttributes :: ![Attribute]
       , iCmdContents   :: ![InlineElement]
       }
-    deriving (Eq, Show)
+    deriving (Eq, Show, Typeable, Data)

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

diff --git a/defaultPages/MainPage b/defaultPages/MainPage
index c64e7b7284ac0accdc580ce3cdc138d4dcd2badc..02abe6bdc46478ff8d55aabbe5c1f734802f013c 100644 (file)
--- a/defaultPages/MainPage
+++ b/defaultPages/MainPage
@@ -12,6 +12,7 @@ Hello, world!
 Another paragraph...
 
 別の段落...<br />次の行...
+<span style="color:red">red <span style="color:blue">blue</span> red</span>
 
 == Subsection ==