From 8d621fced0d1b3f66d38b16cd732fd2342622c5d Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 6 Feb 2008 17:50:15 +0900 Subject: [PATCH] implemented pager darcs-hash:20080206085015-62b54-10660d6cad7328627e769ddca1bd67e6b67ae28c.gz --- Rakka/Page.hs | 7 +- Rakka/Resource/Search.hs | 168 +++++++++++++++++++++++----- defaultPages/StyleSheet/Default.xml | 37 ++++++ 3 files changed, 182 insertions(+), 30 deletions(-) diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 00406c2..5d7ef68 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -12,6 +12,7 @@ module Rakka.Page , pageUpdateInfo , pageRevision + , isSafeChar , encodePageName , decodePageName @@ -151,14 +152,14 @@ encodeFragment = escapeURIString isSafeChar . UTF8.encodeString mkPageURI :: URI -> PageName -> URI mkPageURI baseURI name = baseURI { - uriPath = "/" uriPath baseURI encodePageName name <.> "html" + uriPath = uriPath baseURI encodePageName name <.> "html" } mkPageFragmentURI :: URI -> PageName -> String -> URI mkPageFragmentURI baseURI name fragment = baseURI { - uriPath = "/" uriPath baseURI encodePageName name <.> "html" + uriPath = uriPath baseURI encodePageName name <.> "html" , uriFragment = ('#' : encodeFragment fragment) } @@ -185,7 +186,7 @@ mkAuxiliaryURI baseURI basePath name mkFeedURI :: URI -> PageName -> URI mkFeedURI baseURI name = baseURI { - uriPath = "/" uriPath baseURI encodePageName name <.> "rdf" + uriPath = uriPath baseURI encodePageName name <.> "rdf" } diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs index af90bfa..e4456e8 100644 --- a/Rakka/Resource/Search.hs +++ b/Rakka/Resource/Search.hs @@ -21,7 +21,7 @@ import Rakka.SystemConfig import Rakka.Utils import Rakka.Wiki.Engine import System.FilePath -import Text.HyperEstraier +import Text.HyperEstraier hiding (getText) import Text.XML.HXT.Arrow.Namespace import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlNodeSet @@ -41,8 +41,12 @@ resSearch env } -defaultResultsPerPage :: Int -defaultResultsPerPage = 20 +resultsPerSection :: Int +resultsPerSection = 10 + + +maxSectionWindowSize :: Int +maxSectionWindowSize = 10 {- @@ -65,7 +69,7 @@ handleSearch env let query = UTF8.decodeString $ fromMaybe "" $ lookup "q" params from = fromMaybe 0 $ fmap read $ lookup "from" params - to = fromMaybe defaultResultsPerPage + to = fromMaybe (from + resultsPerSection) $ fmap read $ lookup "to" params cond <- liftIO $ mkCond query from to @@ -186,29 +190,32 @@ searchResultToXHTML env ) += ( getXPathTreesInDoc "/searchResult/page" >>> - eelem "div" - += sattr "class" "searchResult" - += ( eelem "a" - += attr "href" ( getAttrValue "name" - >>> - arr (\ x -> uriToString id (mkPageURI baseURI x) "") - >>> - mkText - ) - += (getAttrValue "name" >>> mkText) - ) - += ( eelem "p" - += ( getChildren - >>> - choiceA [ isText :-> this - , hasName "boundary" :-> txt " ... " - , hasName "hit" :-> ( eelem "span" - += sattr "class" "highlighted" - += getChildren - ) - ] - ) - ) + formatItem baseURI + ) + += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()" + >>> + getText + ) + &&& + ( getXPathTreesInDoc "/searchResult/@from/text()" + >>> + getText + >>> + arr ((`div` resultsPerSection) . read) + ) + &&& + ( getXPathTreesInDoc "/searchResult/@total/text()" + >>> + getText + >>> + arr ((+ 1) . (`div` resultsPerSection) . read) + ) + ) + >>> + ( ((> 1) . snd . snd) + `guardsP` + formatPager baseURI + ) ) ) ) @@ -233,6 +240,113 @@ searchResultToXHTML env >>> uniqueNamespacesFromDeclAndQNames ) ) -<< tree + where + formatItem :: (ArrowXml a, ArrowChoice a) => URI -> a XmlTree XmlTree + formatItem baseURI + = ( eelem "div" + += sattr "class" "searchResult" + += ( eelem "a" + += attr "href" ( getAttrValue "name" + >>> + arr (\ x -> uriToString id (mkPageURI baseURI x) "") + >>> + mkText + ) + += (getAttrValue "name" >>> mkText) + ) + += ( eelem "p" + += ( getChildren + >>> + choiceA [ isText :-> this + , hasName "boundary" :-> txt " ... " + , hasName "hit" :-> ( eelem "span" + += sattr "class" "highlighted" + += getChildren + ) + ] + ) + ) + ) + + formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Int, Int)) XmlTree + formatPager baseURI + = ( eelem "div" + += sattr "class" "pager" + += txt "Page." + += ( ( arr fst + &&& + arr (fst . snd) + &&& + ( arr snd + >>> + mkSectionWindow + ) + ) + >>> + proc (query, (currentSection, section)) + -> if currentSection == section then + ( txt " " + <+> + eelem "span" + += sattr "class" "currentSection" + += (arr show >>> mkText) + ) -< section + else + ( txt " " + <+> + eelem "a" + += attr "href" ( mkSectionURI baseURI + >>> + uriToText + ) + += (arr (show . snd) >>> mkText) + ) -< (query, section) + ) + ) + + mkSectionWindow :: ArrowList a => a (Int, Int) Int + mkSectionWindow + = proc (currentSection, totalSections) + -> let windowWidth = min maxSectionWindowSize totalSections + windowBegin = currentSection - (windowWidth `div` 2) + (begin, end) = if windowBegin < 0 then + -- 左に溢れた + (0, windowWidth - 1) + else + if windowBegin + windowWidth >= totalSections then + -- 右に溢れた + (totalSections - windowWidth, totalSections - 1) + else + -- どちらにも溢れない + (windowBegin, windowBegin + windowWidth - 1) + in + arrL id -< [begin .. end] + + + mkSectionURI :: Arrow a => URI -> a (String, Int) URI + mkSectionURI baseURI + = arr $ \ (query, section) + -> baseURI { + uriPath = uriPath baseURI "search" + , uriQuery = '?' : mkQueryString [ ("q" , query) + , ("from", show $ section * resultsPerSection) + , ("to" , show $ (section + 1) * resultsPerSection - 1) + ] + } + + uriToText :: ArrowXml a => a URI XmlTree + uriToText = arr (\ uri -> uriToString id uri "") >>> mkText + + mkQueryString :: [(String, String)] -> String + mkQueryString [] = "" + mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++ + if xs == [] then + "" + else + ';' : mkQueryString(xs) + + encode :: String -> String + encode = escapeURIString isSafeChar . UTF8.encodeString readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => diff --git a/defaultPages/StyleSheet/Default.xml b/defaultPages/StyleSheet/Default.xml index 74a17db..cdcc83a 100644 --- a/defaultPages/StyleSheet/Default.xml +++ b/defaultPages/StyleSheet/Default.xml @@ -208,6 +208,20 @@ table.pageEditor { margin-bottom: 1.5em; } +.pager { + width: 20em; + + margin-left: auto; + margin-right: auto; + + padding: 10px; +} + +.pager a, +.pager .currentSection { + padding: 4px; +} + /* color and text *************************************************************/ * { font-family: sans-serif; @@ -421,6 +435,29 @@ input[type="button"][disabled]:active { background-color: #ffefd5; } +.pager { + text-align: center; + + background-color: #f5f5f5; + + border-color: #cccccc; + border-width: 1px; + border-style: dotted; +} +.pager .currentSection, +.pager a { + border-style: solid; + border-width: 1px; +} +.pager .currentSection { + background-color: white; + border-color: #cccccc white white #cccccc; +} +.pager a { + background-color: #e8e8e8; + border-color: white #cccccc #cccccc white; +} + /* float **********************************************************************/ h1, h2, h3, h4, h5, h6 { clear: both; -- 2.40.0