From: pho Date: Fri, 19 Oct 2007 06:39:31 +0000 (+0900) Subject: Implemented more features X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=commitdiff_plain;h=2ad43b49ecc25bdf87dd19037fd63c12428992ae Implemented more features darcs-hash:20071019063931-62b54-4e61ec94a58f96f634296b72767fcf441a65bdd2.gz --- diff --git a/Rakka.cabal b/Rakka.cabal index d159d5a..495148e 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -32,13 +32,10 @@ Exposed-Modules: Rakka.Storage Rakka.SystemConfig Rakka.Wiki + Rakka.Wiki.Interpreter Other-Modules: - Rakka.Environment Rakka.Storage.DefaultPage Rakka.Utils - Rakka.Wiki.Engine - Rakka.Wiki.Formatter - Rakka.Wiki.Parser Data-Files: defaultPages/Help/Syntax defaultPages/MainPage @@ -59,6 +56,6 @@ GHC-Options: Executable: RakkaUnitTest Main-Is: - test/RakkaUnitTest.hs + tests/RakkaUnitTest.hs Hs-Source-Dirs: - test + tests diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index 015d37d..d68892b 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -1,13 +1,22 @@ module Rakka.Environment ( Environment(..) + , InterpTable , setupEnv + , getInterpTable + , getInterpTableA ) where +import Control.Arrow.ArrowIO +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as M import Network import qualified Network.HTTP.Lucu.Config as LC import Rakka.Storage import Rakka.SystemConfig +import Rakka.Wiki.Interpreter +import Rakka.Wiki.Interpreter.Base data Environment = Environment { @@ -15,17 +24,41 @@ data Environment = Environment { , envLucuConf :: !LC.Config , envStorage :: !Storage , envSysConf :: !SystemConfig + , envInterpTable :: !(IORef InterpTable) } +type InterpTable = Map String Interpreter + + setupEnv :: FilePath -> PortNumber -> IO Environment setupEnv lsdir portNum = do let lucuConf = LC.defaultConfig { LC.cnfServerPort = PortNumber portNum } + storage = mkStorage + sysConf = mkSystemConfig lucuConf + interpTable <- mkInterpTable return $ Environment { envLocalStateDir = lsdir , envLucuConf = lucuConf - , envStorage = mkStorage - , envSysConf = mkSystemConfig lucuConf + , envStorage = storage + , envSysConf = sysConf + , envInterpTable = interpTable } + + +mkInterpTable :: IO (IORef InterpTable) +mkInterpTable = newIORef (listToTable baseInterpreters) + where + listToTable :: [Interpreter] -> InterpTable + listToTable xs + = M.fromList [ (commandName x, x) | x <- xs ] + + +getInterpTable :: Environment -> IO InterpTable +getInterpTable = readIORef . envInterpTable + + +getInterpTableA :: ArrowIO a => Environment -> a b InterpTable +getInterpTableA = arrIO0 . getInterpTable diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs index b8be3a3..0cf9a13 100644 --- a/Rakka/Wiki.hs +++ b/Rakka/Wiki.hs @@ -8,6 +8,10 @@ module Rakka.Wiki , ListItem , Definition(..) + + , CommandType(..) + , Attribute + , InlineCommand(..) ) where @@ -39,6 +43,8 @@ data InlineElement , linkFragment :: !(Maybe String) , linkText :: !(Maybe String) } + | LineBreak ![Attribute] + | InlineCmd !InlineCommand deriving (Eq, Show) @@ -64,4 +70,21 @@ data Definition defTerm :: ![InlineElement] , defDesc :: ![InlineElement] } - deriving (Eq, Show) \ No newline at end of file + deriving (Eq, Show) + + +data CommandType + = InlineCommandType + | BlockCommandType + + +type Attribute = (String, String) + + +data InlineCommand + = InlineCommand { + iCmdName :: !String + , iCmdAttributes :: ![Attribute] + , iCmdContents :: ![InlineElement] + } + deriving (Eq, Show) diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 4cb150f..6500975 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -8,12 +8,15 @@ import Control.Arrow.ArrowIO import Control.Arrow.ArrowTree import Data.Encoding import Data.Encoding.UTF8 +import qualified Data.Map as M import Network.HTTP.Lucu import Rakka.Environment import Rakka.Page import Rakka.SystemConfig +import Rakka.Wiki import Rakka.Wiki.Parser import Rakka.Wiki.Formatter +import Rakka.Wiki.Interpreter import Text.ParserCombinators.Parsec import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.DOM.TypeDefs @@ -26,23 +29,85 @@ formatPage env = proc page -> do tree <- case pageType page of MIMEType "text" "x-rakka" _ - -> formatWikiPage env -< page + -> do let source = decodeLazy UTF8 (pageContent page) + formatWikiPage env -< (Just page, source) attachXHtmlNs -< tree formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment - -> a Page XmlTree + -> a (Maybe Page, String) XmlTree formatWikiPage env - = proc page - -> do let source = decodeLazy UTF8 (pageContent page) - case parse wikiPage "" source of + = proc (page, source) + -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () + interpTable <- getInterpTableA env -< () + + let parser = wikiPage (tableToFunc interpTable) + + case parse parser "" source of Left err -> formatParseError -< err Right blocks - -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () - formatWikiBlocks -< (baseURI, blocks) + -> do xs <- interpretCommandsA env -< (interpTable, (page, blocks)) + formatWikiBlocks -< (baseURI, xs) + where + tableToFunc :: InterpTable -> String -> Maybe CommandType + tableToFunc table name + = fmap commandType (M.lookup name table) + + +interpretCommandsA :: ArrowIO a => + Environment + -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage +interpretCommandsA = arrIO3 . interpretCommands + + +interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage +interpretCommands _ _ _ [] = return [] +interpretCommands env table page blocks = mapM interpBlock blocks + where + 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 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 } + + interpInline :: InlineElement -> IO InlineElement + interpInline (Italic xs ) = mapM interpInline xs >>= return . Italic + interpInline (Bold xs ) = mapM interpInline xs >>= return . Bold + interpInline (InlineCmd cmd) = interpInlineCmd cmd + interpInline 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 cmd page (envStorage env) (envSysConf env) + >>= + interpInline formatParseError :: ArrowXml a => a ParseError XmlTree diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index 95dd9ff..7a6bde3 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -153,6 +153,16 @@ formatInline link@(PageLink _ _ _) -> formatPageLink -< (baseURI, link) + LineBreak attrs + -> ( eelem "br" + += (arrL id >>> attrFromPair) + ) -< attrs + + +attrFromPair :: (ArrowXml a) => a (String, String) XmlTree +attrFromPair = proc (name, value) + -> attr name (txt value) -<< () + formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree formatPageLink diff --git a/Rakka/Wiki/Interpreter.hs b/Rakka/Wiki/Interpreter.hs new file mode 100644 index 0000000..2abfc45 --- /dev/null +++ b/Rakka/Wiki/Interpreter.hs @@ -0,0 +1,40 @@ +module Rakka.Wiki.Interpreter + ( Interpreter(..) + + , commandName -- private + , commandType -- private + + , pureInlineInterp + ) + where + +import Rakka.Page +import Rakka.Storage +import Rakka.SystemConfig +import Rakka.Wiki + + +data Interpreter + = InlineCommandInterpreter { + iciName :: String + , iciInterpret :: InlineCommand + -> Maybe Page + -> Storage + -> SystemConfig + -> IO InlineElement + } + + +commandName :: Interpreter -> String +commandName (InlineCommandInterpreter name _) = name + + +commandType :: Interpreter -> CommandType +commandType (InlineCommandInterpreter _ _) = InlineCommandType + + +pureInlineInterp :: String + -> (InlineCommand -> Maybe Page -> InlineElement) + -> Interpreter +pureInlineInterp name f + = InlineCommandInterpreter name $ \ cmd page _ _ -> return $ f cmd page diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs new file mode 100644 index 0000000..bd11029 --- /dev/null +++ b/Rakka/Wiki/Interpreter/Base.hs @@ -0,0 +1,17 @@ +module Rakka.Wiki.Interpreter.Base + ( baseInterpreters + ) + where + +import Rakka.Wiki.Interpreter +import Rakka.Wiki + + +baseInterpreters :: [Interpreter] +baseInterpreters = [ lineBreakInterp ] + + +lineBreakInterp :: Interpreter +lineBreakInterp = pureInlineInterp "br" interpret + where + interpret (InlineCommand _ attrs _) _ = LineBreak attrs diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index db26a49..dd87751 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -1,5 +1,6 @@ module Rakka.Wiki.Parser - ( wikiPage + ( CommandTypeOf + , wikiPage ) where @@ -8,36 +9,36 @@ import Rakka.Wiki import Text.ParserCombinators.Parsec -wikiPage :: Parser WikiPage -wikiPage = do xs <- many (try blockElement) - skipMany ( comment - <|> - (newline >> return ()) - ) - eof - return xs +type CommandTypeOf = String -> Maybe CommandType -blockElement :: Parser BlockElement -blockElement = skipMany ( comment - <|> - (newline >> return ()) - ) - >> - ( heading - <|> - horizontalLine - <|> - listElement - <|> - definitionList - <|> - pdata - <|> - leadingSpaced +wikiPage :: CommandTypeOf -> Parser WikiPage +wikiPage cmdTypeOf + = do xs <- many $ try (blockElement cmdTypeOf) + skipMany ( comment + <|> + (newline >> return ()) + ) + eof + return xs + + +blockElement :: CommandTypeOf -> Parser BlockElement +blockElement cmdTypeOf + = skipMany ( comment <|> - paragraph + (newline >> return ()) ) + >> + ( foldr (<|>) pzero [ heading + , horizontalLine + , listElement cmdTypeOf + , definitionList cmdTypeOf + , pdata + , leadingSpaced cmdTypeOf + , paragraph cmdTypeOf + ] + ) heading :: Parser BlockElement @@ -71,27 +72,29 @@ horizontalLine = try ( do count 4 (char '-') "horizontal line" -listElement :: Parser BlockElement -listElement = listElement' [] >>= return . List +listElement :: CommandTypeOf -> Parser BlockElement +listElement cmdTypeOf = listElement' [] >>= return . List where listElement' :: [Char] -> Parser ListElement listElement' stack - = try $ do t <- oneOf "*#" - ws - xs <- items (stack ++ [t]) - return (ListElement (toType t) xs) + = do t <- oneOf "*#" + ws + xs <- items (stack ++ [t]) + return (ListElement (toType t) xs) -- ListItem の終了條件は、 items :: [Char] -> Parser [ListItem] - items stack = do xs <- many1 inlineElement + items stack = do xs <- many1 $ inlineElement cmdTypeOf nested <- option Nothing - $ try $ do newline + $ try $ do skipMany comment + newline string stack listElement' stack >>= return . Just rest <- items stack return $ (map Right xs ++ map Left (catMaybes [nested])) : rest <|> - (try $ do newline + (try $ do skipMany comment + newline string stack ws items stack @@ -104,13 +107,13 @@ listElement = listElement' [] >>= return . List toType '#' = Numbered -definitionList :: Parser BlockElement -definitionList = many1 definition >>= return . DefinitionList +definitionList :: CommandTypeOf -> Parser BlockElement +definitionList cmdTypeOf = many1 definition >>= return . DefinitionList where definition :: Parser Definition definition = do char ';' ws - tHead <- inlineElement + tHead <- inlineElement cmdTypeOf tRest <- term d <- description return (Definition (tHead:tRest) d) @@ -122,14 +125,14 @@ definitionList = many1 definition >>= return . DefinitionList <|> (newline >> char ':' >> ws >> return []) <|> - do x <- inlineElement + do x <- inlineElement cmdTypeOf xs <- term return (x:xs) "term to be defined" description :: Parser [InlineElement] - description = do x <- inlineElement + description = do x <- inlineElement cmdTypeOf xs <- description return (x:xs) <|> @@ -162,13 +165,13 @@ pdata = do try (string "> leadingSpaced' >>= return . Preformatted) - - "leading space" +leadingSpaced :: CommandTypeOf -> Parser BlockElement +leadingSpaced cmdTypeOf = (char ' ' >> leadingSpaced' >>= return . Preformatted) + + "leading space" where leadingSpaced' :: Parser [InlineElement] - leadingSpaced' = do x <- inlineElement + leadingSpaced' = do x <- inlineElement cmdTypeOf xs <- leadingSpaced' return (x:xs) <|> @@ -184,15 +187,15 @@ leadingSpaced = (char ' ' >> leadingSpaced' >>= return . Preformatted) return [] -blockTag :: Parser BlockElement -blockTag = pzero -- not implemented +blockCommand :: Parser BlockElement +blockCommand = pzero -- not implemented -paragraph :: Parser BlockElement -paragraph = paragraph' >>= return . Paragraph +paragraph :: CommandTypeOf -> Parser BlockElement +paragraph cmdTypeOf = paragraph' >>= return . Paragraph where paragraph' :: Parser [InlineElement] - paragraph' = do x <- inlineElement + paragraph' = do x <- inlineElement cmdTypeOf xs <- try ( do newline eof return [] @@ -202,7 +205,7 @@ paragraph = paragraph' >>= return . Paragraph <|> try ( do newline ((oneOf ('\n':blockSymbols) >> pzero) <|> return ()) - ((blockTag >> pzero) <|> return ()) + ((blockCommand >> pzero) <|> return ()) ys <- (paragraph' <|> return []) return (Text "\n" : ys) -- \n があり、その次に \n、ブロックタ @@ -219,17 +222,15 @@ paragraph = paragraph' >>= return . Paragraph return (x:xs) -inlineElement :: Parser InlineElement -inlineElement = skipMany comment - >> - ( cdata - <|> - apostrophes - <|> - text - <|> - pageLink - ) +inlineElement :: CommandTypeOf -> Parser InlineElement +inlineElement cmdTypeOf + = try $ do skipMany comment + foldr (<|>) pzero [ cdata + , apostrophes cmdTypeOf + , text + , pageLink + , inlineCmd cmdTypeOf + ] cdata :: Parser InlineElement @@ -261,25 +262,25 @@ text = ( char ':' "text" -apostrophes :: Parser InlineElement -apostrophes = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5]) +apostrophes :: CommandTypeOf -> Parser InlineElement +apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5]) where apos1 = apos 1 >> return (Text "'") apos2 = do apos 2 - xs <- many1 inlineElement + xs <- many1 $ inlineElement cmdTypeOf apos 2 return (Italic xs) apos3 = do apos 3 - xs <- many1 inlineElement + xs <- many1 $ inlineElement cmdTypeOf apos 3 return (Bold xs) apos4 = apos 4 >> return (Text "'") apos5 = do apos 5 - xs <- many1 inlineElement + xs <- many1 $ inlineElement cmdTypeOf apos 5 return (Italic [Bold xs]) @@ -294,7 +295,7 @@ pageLink = do try (string "[[") fragment <- option Nothing (char '#' >> many1 (noneOf "|]") >>= return . Just) text <- option Nothing - (char '|' >> many1 (noneOf "]") >>= return . Just) + (char '|' >> many1 (satisfy (/= ']')) >>= return . Just) case (page, fragment) of (Nothing, Nothing) -> pzero @@ -306,6 +307,90 @@ pageLink = do try (string "[[") "page link" +inlineCmd :: CommandTypeOf -> Parser InlineElement +inlineCmd cmdTypeOf + = (try $ do (tagName, tagAttrs) <- openTag + case cmdTypeOf tagName of + Just InlineCommandType + -> do xs <- contents + closeTag tagName + return $ InlineCmd $ InlineCommand { + iCmdName = tagName + , iCmdAttributes = tagAttrs + , iCmdContents = xs + } + _ -> pzero + ) + <|> + (try $ do (tagName, tagAttrs) <- emptyTag + case cmdTypeOf tagName of + Just InlineCommandType + -> return $ InlineCmd $ InlineCommand { + iCmdName = tagName + , iCmdAttributes = tagAttrs + , iCmdContents = [] + } + _ -> pzero + ) + where + contents :: Parser [InlineElement] + contents = do x <- inlineElement cmdTypeOf + xs <- contents + return (x:xs) + <|> + (comment >> contents) + <|> + (newline >> contents >>= return . (Text "\n" :)) + <|> + return [] + + +openTag :: Parser (String, [Attribute]) +openTag = try $ do char '<' + many space + name <- many1 letter + many space + attrs <- many $ do attr <- tagAttr + many space + return attr + char '>' + return (name, attrs) + + +emptyTag :: Parser (String, [Attribute]) +emptyTag = try $ do char '<' + many space + name <- many1 letter + many space + attrs <- many $ do attr <- tagAttr + many space + return attr + char '/' + many space + char '>' + return (name, attrs) + + +closeTag :: String -> Parser () +closeTag name = try $ do char '<' + many space + char '/' + many space + string name + many space + char '>' + return () + + +tagAttr :: Parser (String, String) +tagAttr = do name <- many1 letter + char '=' + char '"' + value <- many (satisfy (/= '"')) + char '"' + return (name, value) + + comment :: Parser () comment = (try (string "" + ~?= + (Right [ List (ListElement Bullet [ [Right (Text "a")] ]) ])) + + , (parseWiki "*a\n*b" + ~?= + (Right [ List (ListElement Bullet [ [Right (Text "a")] + , [Right (Text "b")] + ]) + ])) + , (parseWiki "foo:bar" ~?= (Right [ Paragraph [ Text "foo" @@ -277,4 +297,27 @@ testData = [ (parseWiki "" , (parseWiki "'''''foo'''''" ~?= (Right [ Paragraph [ Italic [Bold [Text "foo"]] ] ])) + + , (parseWiki "
" + ~?= + (Right [ Paragraph [ InlineCmd (InlineCommand "br" [] []) ] ])) + + , (parseWiki "
" + ~?= + (Right [ Paragraph [ InlineCmd (InlineCommand "br" [("style", "clear: both")] []) ] ])) + + , (parseWiki "foo" + ~?= + (Right [ Paragraph [ InlineCmd (InlineCommand "i" [] + [ InlineCmd (InlineCommand "b" [] [ Text "foo" ]) ]) ] ])) + + , (parseWiki "\nfoo\n\nbar" + ~?= + (Right [ Paragraph [ InlineCmd (InlineCommand "i" [] + [ Text "\n" + , Text "foo" + , Text "\n" + , Text "\n" + , Text "bar" + ]) ] ])) ]