Implemented block commands

darcs-hash:20071020023044-62b54-0a2bd203d0e572192f874190b686f3afda3f566b.gz

diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs
index e9929903e75fce46e92bd45fc717bbb0632c6666..7b72400cbecbf317590f05a4a159619fc4a42843 100644 (file)
--- a/Rakka/Resource/Render.hs
+++ b/Rakka/Resource/Render.hs
@@ -148,10 +148,16 @@ handleGetEntity env
                         ) -<< ()
 
                 returnA -< do let lastMod = toClockTime $ pageLastMod page
-
-                              case pageRevision page of
-                                Nothing  -> foundTimeStamp lastMod
-                                Just rev -> foundEntity (strongETag $ show rev) lastMod
+                              
+                              -- text/x-rakka の場合は、内容が動的に生
+                              -- 成されてゐる可能性があるので、ETag も
+                              -- Last-Modified も返す事が出來ない。
+                              case pageType page of
+                                MIMEType "text" "x-rakka" _
+                                    -> return ()
+                                _   -> case pageRevision page of
+                                         Nothing  -> foundTimeStamp lastMod
+                                         Just rev -> foundEntity (strongETag $ show rev) lastMod
 
                               outputXmlPage tree entityToXHTML
 

diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs
index 0cf9a135fbdba2658a1da22a79f315908057e15b..0bf23987b5ffed8c5368fd13d85695183a3b89c8 100644 (file)
--- a/Rakka/Wiki.hs
+++ b/Rakka/Wiki.hs
@@ -11,6 +11,7 @@ module Rakka.Wiki
 
     , CommandType(..)
     , Attribute
+    , BlockCommand(..)
     , InlineCommand(..)
     )
     where
@@ -31,6 +32,8 @@ data BlockElement
     | DefinitionList ![Definition]
     | Preformatted ![InlineElement]
     | Paragraph ![InlineElement]
+    | Div ![Attribute] ![BlockElement]
+    | BlockCmd !BlockCommand
     deriving (Eq, Show)
 
 
@@ -44,6 +47,7 @@ data InlineElement
       , linkText     :: !(Maybe String)
       }
     | LineBreak ![Attribute]
+    | Span ![Attribute] ![InlineElement]
     | InlineCmd !InlineCommand
     deriving (Eq, Show)
 
@@ -81,6 +85,15 @@ data CommandType
 type Attribute = (String, String)
 
 
+data BlockCommand
+    = BlockCommand {
+        bCmdName       :: !String
+      , bCmdAttributes :: ![Attribute]
+      , bCmdContents   :: ![BlockElement]
+      }
+    deriving (Eq, Show)
+
+
 data InlineCommand
     = InlineCommand {
         iCmdName       :: !String

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 65009751dde7694c12a52fd4b678f5e5d20261ea..66e2ccc4363cea341c5d8de4cbb82bdea9053219 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -68,10 +68,12 @@ interpretCommands _   _     _    []     = return []
 interpretCommands env table page blocks = mapM interpBlock blocks
     where
       interpBlock :: BlockElement -> IO BlockElement
-      interpBlock (List           list) = interpList list >>= return . List
+      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 (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
@@ -92,9 +94,21 @@ interpretCommands env table page blocks = mapM interpBlock blocks
                                 desc <- mapM interpInline (defDesc def)
                                 return $ def { defTerm = term, defDesc = desc }
 
+      interpBlockCmd :: BlockCommand -> IO BlockElement
+      interpBlockCmd cmd
+          = case M.lookup (bCmdName cmd) table of
+              Nothing
+                  -> fail ("no such interpreter: " ++ bCmdName cmd)
+
+              Just interp
+                  -> bciInterpret interp cmd page (envStorage env) (envSysConf env)
+                     >>=
+                     interpBlock
+
       interpInline :: InlineElement -> IO InlineElement
-      interpInline (Italic    xs ) = mapM interpInline xs >>= return . Italic
-      interpInline (Bold      xs ) = mapM interpInline xs >>= return . Bold
+      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
 

diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index 7a6bde3bc81c631573bac749f5b933f504e2e281..8a9dc1778eb43ca248a8ba75b52b638f67b0bcaa 100644 (file)
--- a/Rakka/Wiki/Formatter.hs
+++ b/Rakka/Wiki/Formatter.hs
@@ -44,11 +44,25 @@ formatBlock
          Paragraph inlines
              -> formatParagraph -< (baseURI, inlines)
 
+         Div attrs contents
+             -> ( eelem "div"
+                  += ( arrL (fst . snd)
+                       >>>
+                       attrFromPair
+                     )
+                  += ( (arr fst &&& arrL (snd . snd))
+                       >>>
+                       formatBlock
+                     )
+                ) -< (baseURI, (attrs, contents))
+
 
 formatHeading :: ArrowXml a => a (Int, String) XmlTree
 formatHeading 
     = proc (level, text)
-    -> selem ("h" ++ show level) [txt text] -<< ()
+    -> mkelem ("h" ++ show level)
+       [ sattr "id" text ]
+       [ txt text        ] -<< ()
 
 
 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree
@@ -158,6 +172,18 @@ formatInline
                   += (arrL id >>> attrFromPair)
                 ) -< attrs
 
+         Span attrs contents
+             -> ( eelem "span"
+                  += ( arrL (fst . snd)
+                       >>>
+                       attrFromPair
+                     )
+                  += ( (arr fst &&& arrL (snd . snd))
+                       >>>
+                       formatInline
+                     )
+                ) -< (baseURI, (attrs, contents))
+
 
 attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
 attrFromPair = proc (name, value)

diff --git a/Rakka/Wiki/Interpreter.hs b/Rakka/Wiki/Interpreter.hs
index 2abfc45e2947bad4f44627401d288bdc5c1df884..bfaab67b0cd742d2ea0f02b7ebaf7b0913fffa9a 100644 (file)
--- a/Rakka/Wiki/Interpreter.hs
+++ b/Rakka/Wiki/Interpreter.hs
@@ -5,6 +5,7 @@ module Rakka.Wiki.Interpreter
     , commandType -- private
 
     , pureInlineInterp
+    , pureBlockInterp
     )
     where
 
@@ -23,14 +24,24 @@ data Interpreter
                      -> SystemConfig
                      -> IO InlineElement
       }
+    | BlockCommandInterpreter {
+        bciName      :: String
+      , bciInterpret :: BlockCommand
+                     -> Maybe Page
+                     -> Storage
+                     -> SystemConfig
+                     -> IO BlockElement
+      }
 
 
 commandName :: Interpreter -> String
 commandName (InlineCommandInterpreter name _) = name
+commandName (BlockCommandInterpreter  name _) = name
 
 
 commandType :: Interpreter -> CommandType
 commandType (InlineCommandInterpreter _ _) = InlineCommandType
+commandType (BlockCommandInterpreter  _ _) = BlockCommandType
 
 
 pureInlineInterp :: String
@@ -38,3 +49,10 @@ pureInlineInterp :: String
                  -> Interpreter
 pureInlineInterp name f
     = InlineCommandInterpreter name $ \ cmd page _ _ -> return $ f cmd page
+
+
+pureBlockInterp :: String
+                -> (BlockCommand -> Maybe Page -> BlockElement)
+                -> Interpreter
+pureBlockInterp name f
+    = BlockCommandInterpreter name $ \ cmd page _ _ -> return $ f cmd page

diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs
index bd11029034d60b45184234e10cd5759263742d19..e03b669fd083ac568fdd0cfccb1237937cbb094b 100644 (file)
--- a/Rakka/Wiki/Interpreter/Base.hs
+++ b/Rakka/Wiki/Interpreter/Base.hs
@@ -8,10 +8,25 @@ import           Rakka.Wiki
 
 
 baseInterpreters :: [Interpreter]
-baseInterpreters = [ lineBreakInterp ]
+baseInterpreters = [ lineBreakInterp
+                   , spanInterp
+                   , divInterp
+                   ]
 
 
 lineBreakInterp :: Interpreter
 lineBreakInterp = pureInlineInterp "br" interpret
     where
       interpret (InlineCommand _ attrs _) _ = LineBreak attrs
+
+
+spanInterp :: Interpreter
+spanInterp = pureInlineInterp "span" interpret
+    where
+      interpret (InlineCommand _ attrs contents) _ = Span attrs contents
+
+
+divInterp :: Interpreter
+divInterp = pureBlockInterp "div" interpret
+    where
+      interpret (BlockCommand _ attrs contents) _ = Div attrs contents
\ No newline at end of file

diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs
index dd87751d29f53e65de60a06e1a404565941b846b..313521c23cf89971862f4091657d9ef22bef5348 100644 (file)
--- a/Rakka/Wiki/Parser.hs
+++ b/Rakka/Wiki/Parser.hs
@@ -14,7 +14,7 @@ type CommandTypeOf = String -> Maybe CommandType
 
 wikiPage :: CommandTypeOf -> Parser WikiPage
 wikiPage cmdTypeOf
-    = do xs <- many $ try (blockElement cmdTypeOf)
+    = do xs <- many (blockElement cmdTypeOf)
          skipMany ( comment
                     <|>
                     (newline >> return ())
@@ -25,20 +25,19 @@ wikiPage cmdTypeOf
 
 blockElement :: CommandTypeOf -> Parser BlockElement
 blockElement cmdTypeOf
-    = skipMany ( comment
-                 <|>
-                 (newline >> return ())
-               )
-      >>
-      ( foldr (<|>) pzero [ heading
-                          , horizontalLine
-                          , listElement cmdTypeOf
-                          , definitionList cmdTypeOf
-                          , pdata
-                          , leadingSpaced cmdTypeOf
-                          , paragraph cmdTypeOf
-                          ]
-      )
+    = try $ do skipMany ( comment
+                          <|>
+                          (newline >> return ())
+                        )
+               foldr (<|>) pzero [ heading
+                                 , horizontalLine
+                                 , listElement cmdTypeOf
+                                 , definitionList cmdTypeOf
+                                 , pdata
+                                 , leadingSpaced cmdTypeOf
+                                 , paragraph cmdTypeOf
+                                 , blockCmd cmdTypeOf
+                                 ]
 
 
 heading :: Parser BlockElement
@@ -205,16 +204,15 @@ paragraph cmdTypeOf = paragraph' >>= return . Paragraph
                             <|>
                             try ( do newline
                                      ((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
-                                     ((blockCommand              >> pzero) <|> return ())
                                      ys <- (paragraph' <|> return [])
                                      return (Text "\n" : ys)
-                                  -- \n があり、その次に \n、ブロックタ
-                                  -- グまたは blockSymbols があれば、
-                                  -- fail して 最初の newline を讀んだ
-                                  -- æ\89\80ã\81¾ã\81§å\8d·ã\81\8dæ\88»ã\81\99ã\80\82
+                                  -- \n があり、その次に \n または
+                                  -- blockSymbols があれば、fail して
+                                  -- 最初の newline を讀んだ所まで卷き
+                                  -- 戻す。
                                 )
                             <|>
-                            try paragraph'
+                            paragraph'
                             -- それ以外の場合は次の inlineElement から
                             -- を讀んで見る。但し一つも無くても良い。
                             <|>
@@ -222,6 +220,44 @@ paragraph cmdTypeOf = paragraph' >>= return . Paragraph
                       return (x:xs)
 
 
+blockCmd :: CommandTypeOf -> Parser BlockElement
+blockCmd cmdTypeOf
+    = (try $ do (tagName, tagAttrs) <- openTag
+                case cmdTypeOf tagName of
+                  Just BlockCommandType
+                      -> do xs <- contents
+                            closeTag tagName
+                            return $ BlockCmd $ BlockCommand {
+                                         bCmdName       = tagName
+                                       , bCmdAttributes = tagAttrs
+                                       , bCmdContents   = xs
+                                       }
+                  _   -> pzero
+      )
+      <|>
+      (try $ do (tagName, tagAttrs) <- emptyTag
+                case cmdTypeOf tagName of
+                  Just BlockCommandType
+                      -> return $ BlockCmd $ BlockCommand {
+                                         bCmdName       = tagName
+                                       , bCmdAttributes = tagAttrs
+                                       , bCmdContents   = []
+                                       }
+                  _   -> pzero
+      )
+      <?>
+      "block command"
+    where
+      contents :: Parser [BlockElement]
+      contents = do x  <- try $ blockElement cmdTypeOf
+                    xs <- contents
+                    return (x:xs)
+                 <|>
+                 (comment >> contents)
+                 <|>
+                 return []
+
+
 inlineElement :: CommandTypeOf -> Parser InlineElement
 inlineElement cmdTypeOf
     = try $ do skipMany comment
@@ -317,7 +353,7 @@ inlineCmd cmdTypeOf
                             return $ InlineCmd $ InlineCommand {
                                          iCmdName       = tagName
                                        , iCmdAttributes = tagAttrs
-                                       , iCmdContents   =  xs
+                                       , iCmdContents   = xs
                                        }
                   _   -> pzero
       )
@@ -332,6 +368,8 @@ inlineCmd cmdTypeOf
                                        }
                   _   -> pzero
       )
+      <?>
+      "inline command"
     where
       contents :: Parser [InlineElement]
       contents = do x  <- inlineElement cmdTypeOf
@@ -408,7 +446,7 @@ comment = (try (string "<!--") >> skipTillEnd 1)
 
 
 blockSymbols :: [Char]
-blockSymbols = " =-*#;"
+blockSymbols = " =-*#;<"
 
 
 inlineSymbols :: [Char]

diff --git a/defaultPages/MainPage b/defaultPages/MainPage
index c5d19712301865256052b085ce91594f4bbb6183..020ba7122a04c406e218dd19c3eedc9887c2e5fd 100644 (file)
--- a/defaultPages/MainPage
+++ b/defaultPages/MainPage
@@ -3,7 +3,7 @@
       type="text/x-rakka"
       isBoring="yes">
   <textData>= Main Page =
-This  is  the    main  page.&lt;br /&gt;
+This  is  the    main  page.
 Hello, world!
 
 Another paragraph...
@@ -39,5 +39,31 @@ but the text is reformatted.
            preformatted
       text.
     [[Foo|Wiki markup is interpreted here.]]
+
+== Listing ==
+* foo
+** bar
+*** baz
+
+# foo
+## bar
+### baz
+
+* foo
+*# bar
+*#* baz
+*# bar
+
+== Link ==
+* [[Page]]
+* [[page]]
+* [[space in a page name]]
+* [[Page|Link to "Page"]]
+* [[Page#Heading]]
+* [[#Main Page]]
+* [[Page#Heading|Link to "Page#Heading"]]
+* [[#example]]
+
+&lt;div id="example" /&gt;
 </textData>
 </page>

diff --git a/tests/WikiParserTest.hs b/tests/WikiParserTest.hs
index d8772a192ebc2917f8fdfe100562b6eb2dfc65ca..026dcaa87fabde522f7864c80d5430172583d8e3 100644 (file)
--- a/tests/WikiParserTest.hs
+++ b/tests/WikiParserTest.hs
@@ -320,4 +320,19 @@ testData = [ (parseWiki ""
                                               , Text "\n"
                                               , Text "bar"
                                               ]) ] ]))
+
+           , (parseWiki "<div>foo</div>"
+              ~?=
+              (Right [ BlockCmd (BlockCommand "div" []
+                                 [ Paragraph [Text "foo"] ]) ]))
+
+           , (parseWiki "<div><!-- comment --></div>"
+              ~?=
+              (Right [ BlockCmd (BlockCommand "div" [] []) ]))
+
+           , (parseWiki "foo<div id=\"bar\"/>"
+              ~?=
+              (Right [ Paragraph [Text "foo"]
+                     , BlockCmd (BlockCommand "div" [("id", "bar")] [])
+                     ]))
            ]