From: pho Date: Sat, 13 Oct 2007 01:06:14 +0000 (+0900) Subject: implemented listing X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=16b140fe235a43f9dfb9b57e69ebc302beeaea27;p=Rakka.git implemented listing darcs-hash:20071013010614-62b54-5a3b750262d290557e05b3d3cac9cac5314b24d3.gz --- diff --git a/Rakka.cabal b/Rakka.cabal index ac736ef..d159d5a 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -40,7 +40,9 @@ Other-Modules: Rakka.Wiki.Formatter Rakka.Wiki.Parser Data-Files: - defaultPages/Main_Page + defaultPages/Help/Syntax + defaultPages/MainPage + defaultPages/StyleSheet/Default schemas/rakka-page-1.0.rng diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs index 9e80df4..3b1802f 100644 --- a/Rakka/Wiki.hs +++ b/Rakka/Wiki.hs @@ -2,6 +2,10 @@ module Rakka.Wiki ( WikiPage , BlockElement(..) , InlineElement(..) + + , ListElement(..) + , ListType(..) + , ListItem ) where @@ -16,6 +20,9 @@ data BlockElement headingLevel :: !Int , headingText :: !String } + | HorizontalLine + | List !ListElement + | LeadingSpaced ![InlineElement] | Paragraph ![InlineElement] deriving (Eq, Show) @@ -28,3 +35,20 @@ data InlineElement , linkText :: !(Maybe String) } deriving (Eq, Show) + + +data ListElement + = ListElement { + listType :: !ListType + , listItems :: ![ListItem] + } + deriving (Eq, Show) + + +data ListType + = Bullet + | Numbered + deriving (Eq, Show) + + +type ListItem = [Either ListElement InlineElement] diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index 8d219d2..1246ab1 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -28,6 +28,15 @@ formatBlock -> case block of Heading level text -> formatHeading -< (level, text) + + HorizontalLine + -> eelem "hr" -< () + + List list + -> formatListElement -< (baseURI, list) + + LeadingSpaced inlines + -> formatLeadingSpaced -< (baseURI, inlines) Paragraph inlines -> formatParagraph -< (baseURI, inlines) @@ -39,6 +48,46 @@ formatHeading -> selem ("h" ++ show level) [txt text] -<< () +formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, ListElement) XmlTree +formatListElement + = proc (baseURI, list) + -> let tag = case listType list of + Bullet -> "ul" + Numbered -> "ol" + in + ( eelem tag + += ( (constA baseURI &&& constL (listItems list)) + >>> + formatListItem + ) + ) -<< () + where + formatListItem :: (ArrowXml a, ArrowChoice a) => a (URI, ListItem) XmlTree + formatListItem + = proc (baseURI, item) + -> eelem "li" + += ( (arr fst &&& arrL snd) + >>> + formatListItem' + ) -< (baseURI, item) + + formatListItem' :: (ArrowXml a, ArrowChoice a) => a (URI, Either ListElement InlineElement) XmlTree + formatListItem' + = proc (baseURI, x) + -> case x of + Left nestedList -> formatListElement -< (baseURI, nestedList) + Right inline -> formatInline -< (baseURI, inline ) + + +formatLeadingSpaced :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree +formatLeadingSpaced + = eelem "pre" + += ( (arr fst &&& arrL snd) + >>> + formatInline + ) + + formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree formatParagraph = eelem "p" diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index 0125419..83e3301 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -3,6 +3,7 @@ module Rakka.Wiki.Parser ) where +import Data.Maybe import Rakka.Wiki import Text.ParserCombinators.Parsec @@ -24,6 +25,12 @@ blockElement = skipMany ( comment ) >> ( heading + <|> + horizontalLine + <|> + listElement + <|> + leadingSpaced <|> paragraph ) @@ -49,6 +56,89 @@ heading = foldr (<|>) pzero (map heading' [1..5]) return (Heading n (x:xs)) +horizontalLine :: Parser BlockElement +horizontalLine = try $ do count 4 (char '-') + many (char '-') + ws + eol + return HorizontalLine + + +listElement :: Parser BlockElement +listElement = listElement' [] >>= return . List + where + listElement' :: [Char] -> Parser ListElement + listElement' stack + = try $ do t <- oneOf "*#" + ws + xs <- items (stack ++ [t]) + return (ListElement (toType t) xs) + + -- ListItem の終了條件は、 + items :: [Char] -> Parser [ListItem] + items stack = do xs <- many1 inlineElement + nested <- option Nothing + $ try $ do newline + string stack + listElement' stack >>= return . Just + rest <- items stack + return $ (map Right xs ++ map Left (catMaybes [nested])) : rest + <|> + (try $ do newline + string stack + ws + items stack + ) + <|> + return [] +{- + items stack = do nested <- listElement' stack + rest <- items stack + return (Left nested : rest) + <|> + do xs <- many1 inlineElement + rest <- items stack + return (Right xs : rest) + <|> + try ( newline + >> + string stack + >> + items stack + ) + <|> + return [] +-} + + toType :: Char -> ListType + toType '*' = Bullet + toType '#' = Numbered + + +leadingSpaced :: Parser BlockElement +leadingSpaced = char ' ' >> leadingSpaced' >>= return . LeadingSpaced + where + leadingSpaced' :: Parser [InlineElement] + leadingSpaced' = do x <- inlineElement + xs <- leadingSpaced' + return (x:xs) + <|> + try ( newline + >> + char ' ' + >> + leadingSpaced' + >>= + return . (Text "\n" :) + ) + <|> + return [] + + +blockTag :: Parser BlockElement +blockTag = pzero -- not implemented + + paragraph :: Parser BlockElement paragraph = paragraph' >>= return . Paragraph where @@ -63,12 +153,13 @@ paragraph = paragraph' >>= return . Paragraph <|> try ( do newline ((oneOf ('\n':blockSymbols) >> pzero) <|> return ()) + ((blockTag >> pzero) <|> return ()) ys <- (paragraph' <|> return []) return (Text "\n" : ys) - -- \n があり、その次に \n または - -- blockSymbols があれば、fail して - -- 最初の newline を讀んだ所まで卷き - -- 戻す。 + -- \n があり、その次に \n、ブロックタ + -- グまたは blockSymbols があれば、 + -- fail して 最初の newline を讀んだ + -- 所まで卷き戻す。 ) <|> try paragraph' @@ -128,7 +219,7 @@ comment = (try (string "