Chucked the Data.Generics to get ugly but 2x faster code.

darcs-hash:20071031070905-62b54-0b9e2d5ae3b8c31e795197e734575ae981819d05.gz

diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs
index c1b7c7dda18adef0195087644057f54cb9f51d16..a519d34a227da9b8a40ec6db7b66108907185fc2 100644 (file)
--- a/Rakka/Wiki.hs
+++ b/Rakka/Wiki.hs
@@ -18,7 +18,6 @@ module Rakka.Wiki
     )
     where
 
-import           Data.Generics
 import           Network.URI
 import           Rakka.Page
 
@@ -29,7 +28,7 @@ type WikiPage = [BlockElement]
 data Element
     = Block  !BlockElement
     | Inline !InlineElement
-    deriving (Eq, Show, Typeable, Data)
+    deriving (Eq, Show)
 
 
 type Attribute = (String, String)
@@ -51,7 +50,7 @@ data BlockElement
     | Div ![Attribute] ![Element]
     | EmptyBlock
     | BlockCmd !BlockCommand
-    deriving (Eq, Show, Typeable, Data)
+    deriving (Eq, Show)
 
 
 data InlineElement
@@ -81,13 +80,13 @@ data InlineElement
     | Input ![Attribute]
     | EmptyInline
     | InlineCmd !InlineCommand
-    deriving (Eq, Show, Typeable, Data)
+    deriving (Eq, Show)
 
 
 data ListType
     = Bullet
     | Numbered
-    deriving (Eq, Show, Typeable, Data)
+    deriving (Eq, Show)
 
 
 type ListItem = [Element]
@@ -98,7 +97,7 @@ data Definition
         defTerm :: ![InlineElement]
       , defDesc :: ![InlineElement]
       }
-    deriving (Eq, Show, Typeable, Data)
+    deriving (Eq, Show)
 
 
 data CommandType
@@ -113,7 +112,7 @@ data BlockCommand
       , bCmdAttributes :: ![Attribute]
       , bCmdContents   :: ![BlockElement]
       }
-    deriving (Eq, Show, Typeable, Data)
+    deriving (Eq, Show)
 
 
 data InlineCommand
@@ -122,4 +121,4 @@ data InlineCommand
       , iCmdAttributes :: ![Attribute]
       , iCmdContents   :: ![InlineElement]
       }
-    deriving (Eq, Show, Typeable, Data)
+    deriving (Eq, Show)

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 1d05d5036ff02fd401ec948894833bb0159be42c..a4b70d79b6c3b8b4ecca2a19b72c7072f6360a16 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -14,7 +14,6 @@ import           Control.Arrow.ArrowList
 import qualified Data.ByteString.Lazy as L
 import           Data.Encoding
 import           Data.Encoding.UTF8
-import           Data.Generics
 import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.Maybe
@@ -222,37 +221,59 @@ interpretCommands sto sysConf interpTable
                  , ctxSysConf    = sysConf
                  }
        in
-         ( arrIO (everywhereM' (mkM $ interpBlockCmd ctx))
-           >>>
-           arrIO (everywhereM' (mkM $ interpInlineCmd ctx))
-         ) -<< targetWiki
+         arrIO2 (mapM . interpBlock) -< (ctx, targetWiki)
     where
-      interpBlockCmd :: InterpreterContext -> BlockElement -> IO BlockElement
-      interpBlockCmd ctx (BlockCmd cmd) = interpBlockCmd' ctx cmd
-      interpBlockCmd _   others         = return others
-
-      interpBlockCmd' :: InterpreterContext -> BlockCommand -> IO BlockElement
-      interpBlockCmd' ctx cmd
+      interpElem :: InterpreterContext -> Element -> IO Element
+      interpElem ctx (Block  b) = interpBlock  ctx b >>= return . Block
+      interpElem ctx (Inline i) = interpInline ctx i >>= return . Inline
+
+      interpBlock :: InterpreterContext -> BlockElement -> IO BlockElement
+      interpBlock ctx (List lType lItems)    = mapM (interpListItem ctx) lItems >>= return . List lType
+      interpBlock ctx (DefinitionList defs)  = mapM (interpDefinition ctx) defs >>= return . DefinitionList
+      interpBlock ctx (Preformatted inlines) = mapM (interpInline ctx) inlines >>= return . Preformatted
+      interpBlock ctx (Paragraph inlines)    = mapM (interpInline ctx) inlines >>= return . Paragraph
+      interpBlock ctx (Div attrs elems)      = mapM (interpElem ctx) elems >>= return . Div attrs
+      interpBlock ctx (BlockCmd bcmd)        = interpBlockCommand ctx bcmd
+      interpBlock _ x = return x
+
+      interpInline :: InterpreterContext -> InlineElement -> IO InlineElement
+      interpInline ctx (Italic inlines)       = mapM (interpInline ctx) inlines >>= return . Italic
+      interpInline ctx (Bold inlines)         = mapM (interpInline ctx) inlines >>= return . Bold
+      interpInline ctx (Span attrs inlines)   = mapM (interpInline ctx) inlines >>= return . Span attrs
+      interpInline ctx (Anchor attrs inlines) = mapM (interpInline ctx) inlines >>= return . Anchor attrs
+      interpInline ctx (InlineCmd icmd)       = interpInlineCommand ctx icmd
+      interpInline _ x = return x
+
+      interpListItem :: InterpreterContext -> ListItem -> IO ListItem
+      interpListItem = mapM . interpElem
+
+      interpDefinition :: InterpreterContext -> Definition -> IO Definition
+      interpDefinition ctx (Definition term desc)
+          = do term' <- mapM (interpInline ctx) term
+               desc' <- mapM (interpInline ctx) desc
+               return (Definition term' desc')
+
+      interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
+      interpBlockCommand ctx cmd
           = case M.lookup (bCmdName cmd) interpTable of
               Nothing
                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 
               Just interp
                   -> bciInterpret interp ctx cmd
+                     >>=
+                     interpBlock ctx
 
-
-      interpInlineCmd :: InterpreterContext -> InlineElement -> IO InlineElement
-      interpInlineCmd ctx (InlineCmd cmd) = interpInlineCmd' ctx cmd
-      interpInlineCmd _   others          = return others
-
-      interpInlineCmd' :: InterpreterContext -> InlineCommand -> IO InlineElement
-      interpInlineCmd' ctx cmd
+      interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
+      interpInlineCommand ctx cmd
           = case M.lookup (iCmdName cmd) interpTable of
               Nothing
                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 
               Just interp
                   -> iciInterpret interp ctx cmd
+                     >>=
+                     interpInline ctx
 
 
 makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
@@ -308,51 +329,67 @@ makeDraft interpTable
                -- wikify して興味のある部分を addText する。
                -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
                      wikiPage <- wikifyPage interpTable -< tree
-                     arrIO0 (everywhereM' (mkM (addBlockText  doc)) wikiPage) -<< ()
-                     arrIO0 (everywhereM' (mkM (addInlineText doc)) wikiPage) -<< ()
-                     returnA -< ()
+                     arrIO2 (mapM_ . addBlockText) -< (doc, wikiPage)
 
            MIMEType _ _ _
                -> returnA -< ()
 
          returnA -< doc
     where
-      addBlockText :: Document -> BlockElement -> IO BlockElement
-      addBlockText doc b
-          = do case b of
-                 Heading _ text
-                     -> addText doc text
-                 _   -> return ()
-               return b
-
-      addInlineText :: Document -> InlineElement -> IO InlineElement
-      addInlineText doc i
-          = do case i of
-                 Text text
-                     -> addText doc text
-                 ObjectLink page Nothing
-                     -> addText doc page
-                 ObjectLink page (Just text)
-                     -> do addHiddenText doc page
-                           addText doc text
-                 PageLink page fragment Nothing
-                     -> addText doc (fromMaybe "" page ++
-                                     fromMaybe "" fragment)
-                 PageLink page fragment (Just text)
-                     -> do addHiddenText doc (fromMaybe "" page ++
-                                              fromMaybe "" fragment)
-                           addText doc text
-                 ExternalLink uri Nothing
-                     -> addText doc (uriToString id uri "")
-                 ExternalLink uri (Just text)
-                     -> do addHiddenText doc (uriToString id uri "")
-                           addText doc text
-                 _   -> return ()
-               return i
-
--- Perform monadic transformation in top-down order.
-everywhereM' :: Monad m => GenericM m -> GenericM m
-everywhereM' f x = f x >>= gmapM (everywhereM' f)
+      addElemText :: Document -> Element -> IO ()
+      addElemText doc (Block  b) = addBlockText  doc b
+      addElemText doc (Inline i) = addInlineText doc i
+
+      addBlockText :: Document -> BlockElement -> IO ()
+      addBlockText doc (Heading _ text)       = addText doc text
+      addBlockText _    HorizontalLine        = return ()
+      addBlockText doc (List _ items)         = mapM_ (addListItemText doc) items
+      addBlockText doc (DefinitionList defs)  = mapM_ (addDefinitionText doc) defs
+      addBlockText doc (Preformatted inlines) = mapM_ (addInlineText doc) inlines
+      addBlockText doc (Paragraph inlines)    = mapM_ (addInlineText doc) inlines
+      addBlockText doc (Div _ elems)          = mapM_ (addElemText doc) elems
+      addBlockText _    EmptyBlock            = return ()
+      addBlockText doc (BlockCmd bcmd)        = addBlockCmdText doc bcmd
+
+      addInlineText :: Document -> InlineElement -> IO ()
+      addInlineText doc (Text text)                       = addText doc text
+      addInlineText doc (Italic inlines)                  = mapM_ (addInlineText doc) inlines
+      addInlineText doc (Bold inlines)                    = mapM_ (addInlineText doc) inlines
+      addInlineText doc (ObjectLink page Nothing)         = addText doc page
+      addInlineText doc (ObjectLink page (Just text))     = addHiddenText doc page
+                                                            >> addText doc text
+      addInlineText doc (PageLink page fragm Nothing)     = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
+      addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
+                                                            >> addText doc text
+      addInlineText doc (ExternalLink uri Nothing)        = addText doc (uriToString id uri "")
+      addInlineText doc (ExternalLink uri (Just text))    = addHiddenText doc (uriToString id uri "")
+                                                            >> addText doc text
+      addInlineText _   (LineBreak _)                     = return ()
+      addInlineText doc (Span _ inlines)                  = mapM_ (addInlineText doc) inlines
+      addInlineText doc (Image src alt)                   = do case src of
+                                                                 Left  uri  -> addHiddenText doc (uriToString id uri "")
+                                                                 Right page -> addHiddenText doc page
+                                                               case alt of
+                                                                 Just text -> addHiddenText doc text
+                                                                 Nothing   -> return ()
+      addInlineText doc (Anchor attrs inlines)            = mapM_ (addInlineText doc) inlines
+      addInlineText _   (Input _)                         = return ()
+      addInlineText _    EmptyInline                      = return ()
+      addInlineText doc (InlineCmd icmd)                  = addInlineCmdText doc icmd
+
+      addListItemText :: Document -> ListItem -> IO ()
+      addListItemText = mapM_ . addElemText
+
+      addDefinitionText :: Document -> Definition -> IO ()
+      addDefinitionText doc (Definition term desc)
+          = do mapM_ (addInlineText doc) term
+               mapM_ (addInlineText doc) desc
+
+      addBlockCmdText :: Document -> BlockCommand -> IO ()
+      addBlockCmdText doc (BlockCommand _ _ blocks) = mapM_ (addBlockText doc) blocks
+
+      addInlineCmdText :: Document -> InlineCommand -> IO ()
+      addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
 
 
 wikifyParseError :: Arrow a => a ParseError WikiPage

diff --git a/Rakka/Wiki/Interpreter/Outline.hs b/Rakka/Wiki/Interpreter/Outline.hs
index 16ed0c5f7999ad52670df7398ca10e41f8a7b647..ef9c32058b03de0a69476090f2a7e8df07aa7d7e 100644 (file)
--- a/Rakka/Wiki/Interpreter/Outline.hs
+++ b/Rakka/Wiki/Interpreter/Outline.hs
@@ -3,7 +3,7 @@ module Rakka.Wiki.Interpreter.Outline
     )
     where
 
-import           Data.Generics
+import           Data.Maybe
 import           Rakka.Wiki
 import           Rakka.Wiki.Interpreter
 
@@ -24,16 +24,24 @@ outlineInterp = BlockCommandInterpreter {
 
 
 mkOutline :: WikiPage -> BlockElement
-mkOutline tree
-    = let headings = listify query tree
-      in
-        fst (mkOutline' emptyOutline 1 headings)
-
-
-query :: Typeable a => a -> Bool
-query = mkQ False $ \ x -> case x of
-                             Heading _ _ -> True
-                             _           -> False
+mkOutline tree = fst (mkOutline' emptyOutline 1 headings)
+    where
+      headings :: [BlockElement]
+      headings = concat (map collectInBlock tree)
+
+      collectInBlock :: BlockElement -> [BlockElement]
+      collectInBlock hd@(Heading _ _)
+          = [hd]
+      collectInBlock (Div _ xs)
+          = concat $ map collectInBlock $ catMaybes (map castToBlock xs)
+      collectInBlock (BlockCmd (BlockCommand _ _ xs))
+          = concat $ map collectInBlock xs
+      collectInBlock _
+          = []
+
+      castToBlock :: Element -> Maybe BlockElement
+      castToBlock (Block e) = Just e
+      castToBlock _         = Nothing
 
 
 emptyOutline :: BlockElement