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
Executable:
RakkaUnitTest
Main-Is:
- test/RakkaUnitTest.hs
+ tests/RakkaUnitTest.hs
Hs-Source-Dirs:
- test
+ tests
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 {
, 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
, ListItem
, Definition(..)
+
+ , CommandType(..)
+ , Attribute
+ , InlineCommand(..)
)
where
, linkFragment :: !(Maybe String)
, linkText :: !(Maybe String)
}
+ | LineBreak ![Attribute]
+ | InlineCmd !InlineCommand
deriving (Eq, Show)
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)
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
= 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
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
--- /dev/null
+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
--- /dev/null
+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
module Rakka.Wiki.Parser
- ( wikiPage
+ ( CommandTypeOf
+ , wikiPage
)
where
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
"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
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)
<|>
(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)
<|>
return (x:xs)
-leadingSpaced :: Parser BlockElement
-leadingSpaced = (char ' ' >> 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)
<|>
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 []
<|>
try ( do newline
((oneOf ('\n':blockSymbols) >> pzero) <|> return ())
- ((blockTag >> pzero) <|> return ())
+ ((blockCommand >> pzero) <|> return ())
ys <- (paragraph' <|> return [])
return (Text "\n" : ys)
-- \n があり、その次に \n、ブロックタ
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
"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])
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
"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 "<!--") >> skipTillEnd 1)
<?>
AC_ARG_VAR([BUILD_TEST_SUITE], [build and install the test suite. (yes / no) (default: no)])
if test "$BUILD_TEST_SUITE" = ""; then
BUILD_TEST_SUITE=False
+elif test "$BUILD_TEST_SUITE" = "yes"; then
+ BUILD_TEST_SUITE=True
+elif test "$BUILD_TEST_SUITE" = "no"; then
+ BUILD_TEST_SUITE=False
else
- if test "$BUILD_TEST_SUITE" = "yes"; then
- BUILD_TEST_SUITE=True
- else
- if test "$BUILD_TEST_SUITE" = "no"; then
- BUILD_TEST_SUITE=False
- else
- AC_MSG_ERROR([BUILD_TEST_SUITE must be either yes or no.])
- fi
- fi
+ AC_MSG_ERROR([BUILD_TEST_SUITE must be either yes or no.])
fi
type="text/x-rakka"
isBoring="yes">
<textData>= Main Page =
-This is the main page.
+This is the main page.<br />
Hello, world!
Another paragraph...
import Text.ParserCombinators.Parsec
+cmdTypeOf :: String -> Maybe CommandType
+cmdTypeOf "br" = Just InlineCommandType
+cmdTypeOf "i" = Just InlineCommandType
+cmdTypeOf "b" = Just InlineCommandType
+cmdTypeOf "span" = Just InlineCommandType
+cmdTypeOf "div" = Just BlockCommandType
+cmdTypeOf _ = Nothing
+
+
parseWiki :: String -> Either String WikiPage
-parseWiki src = case parse wikiPage "" src of
+parseWiki src = case parse (wikiPage cmdTypeOf) "" src of
Left err -> Left (show err)
Right page -> Right page
, List (ListElement Numbered [ [Right (Text "b")] ])
]))
+ , (parseWiki "*a<!-- comment -->"
+ ~?=
+ (Right [ List (ListElement Bullet [ [Right (Text "a")] ]) ]))
+
+ , (parseWiki "*a<!-- comment -->\n*b"
+ ~?=
+ (Right [ List (ListElement Bullet [ [Right (Text "a")]
+ , [Right (Text "b")]
+ ])
+ ]))
+
, (parseWiki "foo:bar"
~?=
(Right [ Paragraph [ Text "foo"
, (parseWiki "'''''foo'''''"
~?=
(Right [ Paragraph [ Italic [Bold [Text "foo"]] ] ]))
+
+ , (parseWiki "<br />"
+ ~?=
+ (Right [ Paragraph [ InlineCmd (InlineCommand "br" [] []) ] ]))
+
+ , (parseWiki "<br style=\"clear: both\"/>"
+ ~?=
+ (Right [ Paragraph [ InlineCmd (InlineCommand "br" [("style", "clear: both")] []) ] ]))
+
+ , (parseWiki "<i><b>foo</b></i>"
+ ~?=
+ (Right [ Paragraph [ InlineCmd (InlineCommand "i" []
+ [ InlineCmd (InlineCommand "b" [] [ Text "foo" ]) ]) ] ]))
+
+ , (parseWiki "<i>\nfoo\n<!-- comment -->\nbar</i>"
+ ~?=
+ (Right [ Paragraph [ InlineCmd (InlineCommand "i" []
+ [ Text "\n"
+ , Text "foo"
+ , Text "\n"
+ , Text "\n"
+ , Text "bar"
+ ]) ] ]))
]
projects / Rakka.git / commitdiff