From: pho Date: Thu, 11 Oct 2007 14:04:58 +0000 (+0900) Subject: wrote more... X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=commitdiff_plain;h=1647278f9393f7382b6e8b8a5e9e14ce50aae718 wrote more... darcs-hash:20071011140458-62b54-bc2c7d82b98de0be509c94a04e7f974717602696.gz --- diff --git a/Makefile b/Makefile index 41fe052..8ae8c88 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ run: build $(EXECUTABLE) .setup-config: $(CABAL_FILE) configure Setup Rakka.buildinfo.in - ./Setup configure + BUILD_TEST_SUITE=yes ./Setup configure configure: configure.ac autoconf @@ -25,6 +25,9 @@ clean: install: build ./Setup install +test: build + ./Setup test + sdist: Setup ./Setup sdist diff --git a/Rakka.buildinfo.in b/Rakka.buildinfo.in index f0b4306..2949f94 100644 --- a/Rakka.buildinfo.in +++ b/Rakka.buildinfo.in @@ -3,3 +3,8 @@ Executable: rakka GHC-Options: -DLOCALSTATEDIR="@RAKKA_LOCALSTATEDIR@" + +Executable: + RakkaUnitTest +Buildable: + @BUILD_TEST_SUITE@ diff --git a/Rakka.cabal b/Rakka.cabal index 31c443a..ac736ef 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -25,7 +25,8 @@ Extensions: 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 @@ -42,6 +43,7 @@ Data-Files: defaultPages/Main_Page schemas/rakka-page-1.0.rng + Executable: rakka Main-Is: @@ -49,4 +51,12 @@ 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 diff --git a/Rakka/Page.hs b/Rakka/Page.hs index c22e520..fdc6220 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -4,6 +4,7 @@ module Rakka.Page , encodePageName , decodePageName , mkPageURI + , mkPageFragmentURI , mkObjectURI ) where @@ -67,6 +68,14 @@ mkPageURI baseURI name } +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 { diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs index 73f299b..307792d 100644 --- a/Rakka/Resource/Object.hs +++ b/Rakka/Resource/Object.hs @@ -9,7 +9,6 @@ import Rakka.Environment import Rakka.Page import Rakka.Storage import Rakka.SystemConfig -import System.FilePath import System.Time diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index 668d814..e992990 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -4,7 +4,6 @@ module Rakka.Resource.Render where import Control.Arrow -import Control.Arrow.ArrowIf import Control.Arrow.ArrowIO import Control.Arrow.ArrowList import Data.Char @@ -72,11 +71,8 @@ handleRedirect env {- - [pageIsBinary が False の場合] - - - - [pageIsBinary が True の場合: content 要素の代はりに object 要素] - - -- data 屬性に URI -} handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ()) handleGetEntity env @@ -115,8 +106,7 @@ 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 @@ -149,13 +139,8 @@ handleGetEntity env += 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 @@ -182,24 +167,11 @@ entityToXHTML += 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" @@ -214,12 +186,6 @@ entityToXHTML += ( eelem "div" += sattr "class" "body" += getXPathTreesInDoc "/page/content/*" - += ( getXPathTreesInDoc "/page/object" - `guards` - eelem "object" - += attr "data" - ( getXPathTreesInDoc "/page/object/@data/text()" ) - ) ) ) += ( eelem "div" diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs index f08aa96..c5c2c68 100644 --- a/Rakka/Wiki.hs +++ b/Rakka/Wiki.hs @@ -6,6 +6,9 @@ module Rakka.Wiki ) where +import Rakka.Page + + type WikiPage = [WikiElement] @@ -16,9 +19,9 @@ data WikiElement data BlockElement - = Header { - hdLevel :: !Int - , hdText :: !String + = Heading { + headingLevel :: !Int + , headingText :: !String } | EmptyLine deriving (Eq, Show) @@ -26,4 +29,9 @@ data BlockElement data InlineElement = Text !String + | PageLink { + linkPage :: !(Maybe PageName) + , linkFragment :: !(Maybe String) + , linkText :: !(Maybe String) + } deriving (Eq, Show) diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 56a7adb..5aa5db4 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -4,11 +4,14 @@ module Rakka.Wiki.Engine 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 @@ -16,24 +19,30 @@ import Text.XML.HXT.Arrow.XmlArrow 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 diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index 1054d17..f523938 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -6,6 +6,9 @@ module Rakka.Wiki.Formatter 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 @@ -28,43 +31,63 @@ packParagraph elems = map pack grp 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) diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index b5ec74d..968e645 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -3,69 +3,124 @@ module Rakka.Wiki.Parser ) 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 "") >> 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 ) diff --git a/Setup.hs b/Setup.hs index 39a7547..857ea9c 100755 --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,10 @@ #!/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" diff --git a/configure.ac b/configure.ac index 1a6e943..05516ed 100644 --- a/configure.ac +++ b/configure.ac @@ -2,6 +2,7 @@ AC_INIT([Rakka], [], [phonohawk at ps dot sakura dot ne dot jp]) 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! @@ -12,6 +13,25 @@ fi 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 ]) diff --git a/defaultPages/Help/Syntax b/defaultPages/Help/Syntax index 39c38f4..ece7fb9 100644 --- a/defaultPages/Help/Syntax +++ b/defaultPages/Help/Syntax @@ -4,11 +4,13 @@ isBoring="yes"> = Syntax Help = -== Header == +== Heading == -=== Header 3 === +=== Heading 3 === -==== Header 4 ==== +==== Heading 4 ==== + +===== Heading 5 ===== == Verbatim == This @@ -47,9 +49,9 @@ blah blah blah blah... == 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] diff --git a/defaultPages/MainPage b/defaultPages/MainPage index 632b1bd..4ab9d1e 100644 --- a/defaultPages/MainPage +++ b/defaultPages/MainPage @@ -3,5 +3,27 @@ type="text/x-rakka" isBoring="yes"> = Main Page = -This is the main page. Hello, world! +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]] + diff --git a/test/RakkaUnitTest.hs b/test/RakkaUnitTest.hs new file mode 100644 index 0000000..3099a96 --- /dev/null +++ b/test/RakkaUnitTest.hs @@ -0,0 +1,7 @@ +import Test.HUnit +import qualified WikiParserTest + +main = runTestTT (test testData) + +testData :: [Test] +testData = WikiParserTest.testData \ No newline at end of file diff --git a/test/WikiParserTest.hs b/test/WikiParserTest.hs new file mode 100644 index 0000000..b4e95b1 --- /dev/null +++ b/test/WikiParserTest.hs @@ -0,0 +1,132 @@ +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 "" + ~?= + (Right [])) + + , (parseWiki "foo" + ~?= + (Right [Inline (Text "foo")])) + + , (parseWiki "foo" + ~?= + (Right [Inline (Text "foo")])) + + , (parseWiki "foobar" + ~?= + (Right [ Inline (Text "foo") + , Inline (Text "bar") + ])) + + , (parseWiki "=h=" + ~?= + (Right [Block (Heading 1 "h")])) + + , (parseWiki "=h= " + ~?= + (Right [Block (Heading 1 "h")])) + + , (parseWiki " 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) + ])) + ]