$(EXECUTABLE)
.setup-config: $(CABAL_FILE) configure Setup Rakka.buildinfo.in
- ./Setup configure
+ BUILD_TEST_SUITE=yes ./Setup configure
configure: configure.ac
autoconf
install: build
./Setup install
+test: build
+ ./Setup test
+
sdist: Setup
./Setup sdist
rakka
GHC-Options:
-DLOCALSTATEDIR="@RAKKA_LOCALSTATEDIR@"
+
+Executable:
+ RakkaUnitTest
+Buildable:
+ @BUILD_TEST_SUITE@
GHC-Options:
-fwarn-unused-imports
Build-Depends:
- Crypto, HsSVN, Lucu, base, encoding, filepath, hxt, mtl, network, parsec, unix
+ Crypto, HUnit, HsSVN, Lucu, base, encoding, filepath, hxt, mtl,
+ network, parsec, unix
Exposed-Modules:
Rakka.Page
Rakka.Storage
defaultPages/Main_Page
schemas/rakka-page-1.0.rng
+
Executable:
rakka
Main-Is:
Extensions:
Arrows
GHC-Options:
- -fwarn-unused-imports
\ No newline at end of file
+ -fwarn-unused-imports
+
+
+Executable:
+ RakkaUnitTest
+Main-Is:
+ test/RakkaUnitTest.hs
+Hs-Source-Dirs:
+ test
, encodePageName
, decodePageName
, mkPageURI
+ , mkPageFragmentURI
, mkObjectURI
)
where
}
+mkPageFragmentURI :: URI -> PageName -> String -> URI
+mkPageFragmentURI baseURI name fragment
+ = baseURI {
+ uriPath = foldl combine "/" [uriPath baseURI, encodePageName name]
+ , uriFragment = ('#':fragment)
+ }
+
+
mkObjectURI :: URI -> PageName -> URI
mkObjectURI baseURI name
= baseURI {
import Rakka.Page
import Rakka.Storage
import Rakka.SystemConfig
-import System.FilePath
import System.Time
where
import Control.Arrow
-import Control.Arrow.ArrowIf
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import Data.Char
{-
- [pageIsBinary が False の場合]
-
<page site="CieloNegro"
- baseURI="http://example.org/"
- styleSheet="StyleSheet/Default"
+ styleSheet="http://example.org/object/StyleSheet/Default"
name="Foo/Bar"
type="text/x-rakka"
isTheme="no" -- text/css の場合のみ存在
blah blah...
</content>
</page>
-
-
- [pageIsBinary が True の場合: content 要素の代はりに object 要素]
-
- <object data="/object/Foo/Bar" /> -- data 屬性に URI
-}
handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
handleGetEntity env
tree <- ( eelem "/"
+= ( eelem "page"
+= sattr "site" siteName
- += sattr "baseURI" (uriToString id baseURI "")
- += sattr "styleSheet" cssName
+ += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
+= sattr "name" (pageName page)
+= sattr "type" (show $ pageType page)
+= ( case pageType page of
+= sattr "page" page
| (lang, page) <- xs ]
)
-
- += ( case pageIsBinary page of
- False -> eelem "content"
- += (constA page >>> formatPage)
-
- True -> eelem "object"
- += sattr "data" (uriToString id (mkObjectURI baseURI $ pageName page) "")
+ += ( eelem "content"
+ += (constA page >>> formatPage env )
)
>>>
uniqueNamespacesFromDeclAndQNames
+= txt " - "
+= getXPathTreesInDoc "/page/@name/text()"
)
- += ( eelem "base"
- += attr "href"
- ( getXPathTreesInDoc "/page/@baseURI/text()" )
- )
+= ( eelem "link"
+= sattr "rel" "stylesheet"
+= sattr "type" "text/css"
+= attr "href"
- ( txt "./object/"
- <+>
- getXPathTreesInDoc "/page/@styleSheet/text()"
- >>>
- getText
- >>>
- arr encodePageName
- >>>
- mkText
- )
+ ( getXPathTreesInDoc "/page/@styleSheet/text()" )
)
)
+= ( eelem "body"
+= ( eelem "div"
+= sattr "class" "body"
+= getXPathTreesInDoc "/page/content/*"
- += ( getXPathTreesInDoc "/page/object"
- `guards`
- eelem "object"
- += attr "data"
- ( getXPathTreesInDoc "/page/object/@data/text()" )
- )
)
)
+= ( eelem "div"
)
where
+import Rakka.Page
+
+
type WikiPage = [WikiElement]
data BlockElement
- = Header {
- hdLevel :: !Int
- , hdText :: !String
+ = Heading {
+ headingLevel :: !Int
+ , headingText :: !String
}
| EmptyLine
deriving (Eq, Show)
data InlineElement
= Text !String
+ | PageLink {
+ linkPage :: !(Maybe PageName)
+ , linkFragment :: !(Maybe String)
+ , linkText :: !(Maybe String)
+ }
deriving (Eq, Show)
where
import Control.Arrow
+import Control.Arrow.ArrowIO
import Control.Arrow.ArrowTree
import Data.Encoding
import Data.Encoding.UTF8
import Network.HTTP.Lucu
+import Rakka.Environment
import Rakka.Page
+import Rakka.SystemConfig
import Rakka.Wiki.Parser
import Rakka.Wiki.Formatter
import Text.ParserCombinators.Parsec
import Text.XML.HXT.DOM.TypeDefs
-formatPage :: (ArrowXml a, ArrowChoice a) =>
- a Page XmlTree
-formatPage
+formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Environment
+ -> a Page XmlTree
+formatPage env
= proc page
-> do tree <- case pageType page of
MIMEType "text" "x-rakka" _
- -> formatWikiPage -< page
+ -> formatWikiPage env -< page
attachXHtmlNs -< tree
-formatWikiPage :: (ArrowXml a, ArrowChoice a) =>
- a Page XmlTree
-formatWikiPage
+formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Environment
+ -> a Page XmlTree
+formatWikiPage env
= proc page
-> do let source = decodeLazy UTF8 (pageContent page)
case parse wikiPage "" source of
- Left err -> formatParseError -< err
- Right elems -> formatWikiElements -< elems
+ Left err
+ -> formatParseError -< err
+
+ Right elems
+ -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+ formatWikiElements -< (baseURI, elems)
formatParseError :: ArrowXml a => a ParseError XmlTree
import Control.Arrow
import Control.Arrow.ArrowList
import Data.List
+import Data.Maybe
+import Network.URI
+import Rakka.Page
import Rakka.Wiki
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.DOM.TypeDefs
Inline i -> i | x <- xs ]
-formatWikiElements :: (ArrowXml a, ArrowChoice a) => a [WikiElement] XmlTree
+formatWikiElements :: (ArrowXml a, ArrowChoice a) => a (URI, [WikiElement]) XmlTree
formatWikiElements
- = proc elems
+ = proc (baseURI, elems)
-> do chunk <- arrL id -< packParagraph elems
case chunk of
Left x -> formatBlock -< x
- Right xs -> formatParagraph -< xs
+ Right xs -> formatParagraph -< (baseURI, xs)
formatBlock :: (ArrowXml a, ArrowChoice a) => a BlockElement XmlTree
formatBlock
= proc b
- -> do case b of
- Header level text
- -> formatHeader -< (level, text)
- EmptyLine
- -> none -< ()
+ -> case b of
+ Heading level text
+ -> formatHeading -< (level, text)
+ EmptyLine
+ -> none -< ()
-formatHeader :: ArrowXml a => a (Int, String) XmlTree
-formatHeader
+formatHeading :: ArrowXml a => a (Int, String) XmlTree
+formatHeading
= proc (level, text)
-> selem ("h" ++ show level) [txt text] -<< ()
-formatParagraph :: (ArrowXml a, ArrowChoice a) => a [InlineElement] XmlTree
+formatParagraph :: (ArrowXml a, ArrowChoice a) => a (URI, [InlineElement]) XmlTree
formatParagraph
- = proc xs
- -> do elem <- arrL id -< xs
- tree <- ( eelem "p"
- += formatInline ) -< elem
- returnA -< tree
+ = eelem "p"
+ += ( (arr fst &&& arrL snd)
+ >>>
+ formatInline
+ )
-formatInline :: (ArrowXml a, ArrowChoice a) => a InlineElement XmlTree
+formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
formatInline
- = proc i
- -> do case i of
- Text text
- -> mkText -< text
+ = proc (baseURI, i)
+ -> case i of
+ Text text
+ -> mkText -< text
+
+ link@(PageLink _ _ _)
+ -> formatPageLink -< (baseURI, link)
+
+
+formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
+formatPageLink
+ = proc (baseURI, PageLink page fragment text)
+ -> let uri = case (page, fragment) of
+ (Just x, Just y) -> mkPageFragmentURI baseURI x y
+ (Just x, Nothing) -> mkPageURI baseURI x
+ (Nothing, Just y) -> nullURI { uriFragment = ('#':y) }
+ href = uriToString id uri ""
+ dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
+ label = fromMaybe dLabel text
+ in
+ ( eelem "a"
+ += attr "href" (arr fst >>> mkText)
+ += (arr snd >>> mkText)
+ ) -< (href, label)
)
where
+import Data.Char
import Rakka.Wiki
import Text.ParserCombinators.Parsec
wikiPage :: Parser WikiPage
-wikiPage = do xs <- many wikiElement
+wikiPage = do xs <- many (try wikiElement)
+ skipMany comment
eof
return xs
wikiElement :: Parser WikiElement
-wikiElement = ( try (blockElement >>= return . Block)
+wikiElement = skipMany comment >>
+ ( try (blockElement >>= return . Block)
<|>
try (inlineElement >>= return . Inline)
)
blockElement :: Parser BlockElement
-blockElement = ( try header
+blockElement = ( try heading
<|>
try emptyLine
)
-header :: Parser BlockElement
-header = foldr (<|>) pzero (map (try . header') [1..5])
+heading :: Parser BlockElement
+heading = foldr (<|>) pzero (map (try . heading') [1..5])
+ <?>
+ "heading"
where
- header' :: Int -> Parser BlockElement
- header' n = do count n (char '=')
- notFollowedBy (char '=')
- ws
- x <- notFollowedBy (char '=') >> anyChar
- xs <- manyTill anyChar (try $ ws >> (count n (char '=')))
- ws
- eol
- return (Header n (x:xs))
+ heading' :: Int -> Parser BlockElement
+ heading' n = do count n (char '=')
+ notFollowedBy (char '=')
+ ws
+ x <- notFollowedBy (char '=') >> anyChar
+ xs <- manyTill anyChar (try $ ws >> (count n (char '=')))
+ ws
+ eol
+ return (Heading n (x:xs))
emptyLine :: Parser BlockElement
-emptyLine = newline >> return EmptyLine
+emptyLine = count 2 newline >> many newline >> return EmptyLine
+ <?>
+ "empty line"
inlineElement :: Parser InlineElement
-inlineElement = text
+inlineElement = ( try text
+ <|>
+ try pageLink
+ )
text :: Parser InlineElement
-text = do xs <- many1 (noneOf symbols)
- nl <- option "" (count 1 newline)
- return $ Text (xs ++ nl)
-
+text = text' >>= return . Text
+ where
+ text' :: Parser String
+ text' = do x <- noneOf inlineSymbols
+ case x of
+ -- 單獨の \n は受け入れる。
+ '\n' -> return [x]
+ -- それ以外では \n を受け入れない。
+ _ -> many (noneOf ('\n':inlineSymbols)) >>= return . (x:)
+
+
+pageLink :: Parser InlineElement
+pageLink = do string "[["
+ page <- option Nothing $
+ do x <- satisfy (\ c -> not (elem c "#|]" || isLower c))
+ xs <- many (noneOf "#|]")
+ return $ Just (x:xs)
+ fragment <- option Nothing
+ (char '#' >> many1 (noneOf "|]") >>= return . Just)
+ text <- option Nothing
+ (char '|' >> many1 (noneOf "]") >>= return . Just)
+
+ case (page, fragment) of
+ (Nothing, Nothing) -> pzero
+ (_, _) -> return ()
+
+ string "]]"
+ return $ PageLink page fragment text
+ <?>
+ "page link"
+
+
+comment :: Parser ()
+comment = (try (string "<!--") >> skipTillEnd 1)
+ <?>
+ "comment"
+ where
+ skipTillEnd :: Int -> Parser ()
+ skipTillEnd level = ( (try (string "<!--") >> skipTillEnd (level + 1))
+ <|>
+ (try (string "-->") >> case level of
+ 1 -> return ()
+ n -> skipTillEnd (n - 1))
+ <|>
+ (anyChar >> skipTillEnd level)
+ )
-symbols :: [Char]
-symbols = "\n"
+inlineSymbols :: [Char]
+inlineSymbols = "<["
-- white space
-ws :: Parser String
-ws = many (oneOf " \t")
+ws :: Parser ()
+ws = skipMany ( (oneOf " \t" >> return ())
+ <|>
+ comment
+ )
-- end of line
eol :: Parser ()
-eol = ( (newline >> return ())
+eol = ( (many1 newline >> return ())
<|>
eof
)
#!/usr/bin/env runghc
import Distribution.Simple
-main = defaultMainWithHooks defaultUserHooks
+import System.Cmd
+import System.Exit
+
+main = defaultMainWithHooks (defaultUserHooks { runTests = runTestUnit })
+ where
+ runTestUnit _ _ _ _
+ = system "./dist/build/RakkaUnitTest/RakkaUnitTest"
AC_CONFIG_SRCDIR([Rakka.cabal])
+
# $localstatedir has a reference to ${prefix} but the ${prefix} is
# "NONE" at this time. AC_OUTPUT changes the value of ${prefix} from
# "NONE" to $ac_default_prefix but it's too late!
RAKKA_LOCALSTATEDIR=`eval echo "$localstatedir"`/rakka
AC_SUBST([RAKKA_LOCALSTATEDIR])
+
+# Since the Cabal executes ./configure with no arguments, the only way
+# we can receive options from user is to see environment variables.
+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
+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
+fi
+
+
AC_CONFIG_FILES([
Rakka.buildinfo
])
isBoring="yes">
<textData>= Syntax Help =
-== Header ==
+== Heading ==
-=== Header 3 ===
+=== Heading 3 ===
-==== Header 4 ====
+==== Heading 4 ====
+
+===== Heading 5 =====
== Verbatim ==
This
== Link ==
* [[Page]]
* [[Page|Link to "Page"]]
-* [[Page#Header]]
-* [[#Header]]
-* [[Page#Header|Link to "Page#Header"]]
+* [[Page#Heading]]
+* [[#Heading]]
+* [[Page#Heading|Link to "Page#Heading"]]
* [[#example]]
* http://www.google.com/
* [http://www.google.com Google]
type="text/x-rakka"
isBoring="yes">
<textData>= Main Page =
-This is the main page. Hello, world!</textData>
+This is the main page.
+Hello, world!
+
+Another paragraph...
+
+= Syntax Help =
+
+== Heading ==
+
+=== Heading 3 ===
+
+==== Heading 4 ====
+
+===== Heading 5 =====
+
+== Link ==
+[[Page]]
+[[Page|Link to "Page"]]
+[[Page#Heading]]
+[[#Heading]]
+[[Page#Heading|Link to "Page#Heading"]]
+[[#example]]
+</textData>
</page>
--- /dev/null
+import Test.HUnit
+import qualified WikiParserTest
+
+main = runTestTT (test testData)
+
+testData :: [Test]
+testData = WikiParserTest.testData
\ No newline at end of file
--- /dev/null
+module WikiParserTest
+ ( testData
+ )
+ where
+
+import Rakka.Wiki
+import Rakka.Wiki.Parser
+import Test.HUnit
+import Text.ParserCombinators.Parsec
+
+
+parseWiki :: String -> Either String WikiPage
+parseWiki src = case parse wikiPage "" src of
+ Left err -> Left (show err)
+ Right page -> Right page
+
+
+testData :: [Test]
+testData = [ (parseWiki ""
+ ~?=
+ (Right []))
+
+ , (parseWiki "=heading="
+ ~?=
+ (Right [Block (Heading 1 "heading")]))
+
+ , (parseWiki "== heading == \n"
+ ~?=
+ (Right [Block (Heading 2 "heading")]))
+
+ , (parseWiki "===== hello world =====\n"
+ ~?=
+ (Right [Block (Heading 5 "hello world")]))
+
+ , (parseWiki "a =not a heading="
+ ~?=
+ (Right [Inline (Text "a =not a heading=")]))
+
+ , (parseWiki "=h=\n\n=h="
+ ~?=
+ (Right [ Block (Heading 1 "h")
+ , Block (Heading 1 "h")
+ ]))
+
+ , (parseWiki "foo\nbar\n\nbaz\n"
+ ~?=
+ (Right [ Inline (Text "foo")
+ , Inline (Text "\n")
+ , Inline (Text "bar")
+ , Block EmptyLine
+ , Inline (Text "baz")
+ , Inline (Text "\n")
+ ]))
+
+ , (parseWiki "foo\n\n\nbar"
+ ~?=
+ (Right [ Inline (Text "foo")
+ , Block EmptyLine
+ , Inline (Text "bar")
+ ]))
+
+ , (parseWiki "foo\n=h="
+ ~?=
+ (Right [ Inline (Text "foo")
+ , Inline (Text "\n")
+ , Block (Heading 1 "h")
+ ]))
+
+ , (parseWiki "<!-- comment -->"
+ ~?=
+ (Right []))
+
+ , (parseWiki "<!-- comment -->foo"
+ ~?=
+ (Right [Inline (Text "foo")]))
+
+ , (parseWiki "foo<!-- comment -->"
+ ~?=
+ (Right [Inline (Text "foo")]))
+
+ , (parseWiki "foo<!-- comment -->bar"
+ ~?=
+ (Right [ Inline (Text "foo")
+ , Inline (Text "bar")
+ ]))
+
+ , (parseWiki "<!-- comment -->=h="
+ ~?=
+ (Right [Block (Heading 1 "h")]))
+
+ , (parseWiki "=h= <!---->"
+ ~?=
+ (Right [Block (Heading 1 "h")]))
+
+ , (parseWiki "<!-- <!-- nested --> comment -->"
+ ~?=
+ (Right []))
+
+ , (parseWiki "[[Page]]"
+ ~?=
+ (Right [Inline (PageLink (Just "Page") Nothing Nothing)]))
+
+ , (parseWiki "[[Page|Link to \"Page\"]]"
+ ~?=
+ (Right [Inline (PageLink (Just "Page") Nothing (Just "Link to \"Page\""))]))
+
+ , (parseWiki "[[Page#foo]]"
+ ~?=
+ (Right [Inline (PageLink (Just "Page") (Just "foo") Nothing)]))
+
+ , (parseWiki "[[#foo]]"
+ ~?=
+ (Right [Inline (PageLink Nothing (Just "foo") Nothing)]))
+
+ , (parseWiki "[[Page#foo|Link to \"Page#foo\"]]"
+ ~?=
+ (Right [Inline (PageLink (Just "Page") (Just "foo") (Just "Link to \"Page#foo\""))]))
+
+ , (parseWiki "foo [[Bar]] baz"
+ ~?=
+ (Right [ Inline (Text "foo ")
+ , Inline (PageLink (Just "Bar") Nothing Nothing)
+ , Inline (Text " baz")
+ ]))
+
+ , (parseWiki "[[Foo]]\n[[Bar]]"
+ ~?=
+ (Right [ Inline (PageLink (Just "Foo") Nothing Nothing)
+ , Inline (Text "\n")
+ , Inline (PageLink (Just "Bar") Nothing Nothing)
+ ]))
+ ]
projects / Rakka.git / commitdiff