From: pho Date: Sat, 20 Oct 2007 02:30:44 +0000 (+0900) Subject: Implemented block commands X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=f832f12703d807f5fc3350dc71d8624ffc5b97a5;p=Rakka.git Implemented block commands darcs-hash:20071020023044-62b54-0a2bd203d0e572192f874190b686f3afda3f566b.gz --- diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index e992990..7b72400 100644 --- 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 0cf9a13..0bf2398 100644 --- 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 6500975..66e2ccc 100644 --- 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 7a6bde3..8a9dc17 100644 --- 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 2abfc45..bfaab67 100644 --- 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 bd11029..e03b669 100644 --- 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 dd87751..313521c 100644 --- 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 を讀んだ - -- 所まで卷き戻す。 + -- \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 "" + ~?= + (Right [ BlockCmd (BlockCommand "div" [] []) ])) + + , (parseWiki "foo
" + ~?= + (Right [ Paragraph [Text "foo"] + , BlockCmd (BlockCommand "div" [("id", "bar")] []) + ])) ]