From 45a315230ec341d3f7a9b80f8004148949a5e2e5 Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 31 Oct 2007 16:09:05 +0900 Subject: [PATCH] Chucked the Data.Generics to get ugly but 2x faster code. darcs-hash:20071031070905-62b54-0b9e2d5ae3b8c31e795197e734575ae981819d05.gz --- Rakka/Wiki.hs | 15 ++- Rakka/Wiki/Engine.hs | 151 +++++++++++++++++++----------- Rakka/Wiki/Interpreter/Outline.hs | 30 +++--- 3 files changed, 120 insertions(+), 76 deletions(-) diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs index c1b7c7d..a519d34 100644 --- 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 1d05d50..a4b70d7 100644 --- 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 16ed0c5..ef9c320 100644 --- 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 -- 2.40.0