From: pho Date: Sun, 21 Oct 2007 09:18:12 +0000 (+0900) Subject: The experimental code worked like a magic. I can't believe that. X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=bd2b1344f5ed3d4de91297bfe08658e52d682b82;p=Rakka.git 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 859d305..7380ae4 100644 --- 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 f0e38fe..96231a4 100644 --- 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 3300181..1da0d0e 100644 --- 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 c64e7b7..02abe6b 100644 --- a/defaultPages/MainPage +++ b/defaultPages/MainPage @@ -12,6 +12,7 @@ Hello, world! Another paragraph... 別の段落...
次の行... +red blue red == Subsection ==