/
Render.hs
164 lines (149 loc) · 6.95 KB
/
Render.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module Yst.Render (renderPage)
where
import Yst.Types
import Yst.Util
import Yst.Data
import System.Directory
import Text.Pandoc hiding (Format)
import Text.XHtml hiding (option, (</>))
import Data.Char
import Data.List (intercalate)
import Data.List.Split (wordsBy)
import Text.StringTemplate
import Data.Maybe (fromMaybe)
import System.FilePath
-- Note: ghc >= 6.12 (base >=4.2) supports unicode through iconv
-- So we use System.IO.UTF8 only if we have an earlier version
#if MIN_VERSION_base(4,2,0)
#else
import Prelude hiding (readFile, putStrLn, print, writeFile)
import System.IO.UTF8
#endif
import Data.Time
import Control.Monad
-- | @relUrl a b@ returns a URL for @b@ relative to @a@. So, for
-- example, @relUrl "a" "a/b.html" = "b.html"@,
-- @relUrl "" "a/b.html" = "a/b.html"@, and @relUrl "a" "b.html" = "../b.html"@
relUrl :: String -> String -> String
relUrl relto url = intercalate "/" $ relPath ++ [urlBase]
where relPath = relPaths reltoPaths urlPaths
(reltoPaths, urlPaths) = dropCommon (wordsBy (=='/') relto) (wordsBy (=='/') urlDir)
urlBase = takeUrlBase url
urlDir = takeUrlDir url
takeUrlBase :: String -> String
takeUrlBase = reverse . takeWhile (/= '/') . reverse
takeUrlDir :: String -> String
takeUrlDir = reverse . dropWhile (== '/') . dropWhile (/= '/') . reverse
relPaths :: [String] -> [String] -> [String]
relPaths [] ys = ys
relPaths (_:xs) ys = ".." : relPaths xs ys
dropCommon :: (Eq a) => [a] -> [a] -> ([a],[a])
dropCommon (x:xs) (y:ys) | x == y = dropCommon xs ys
dropCommon xs ys = (xs,ys)
renderNav :: String -> [NavNode] -> String
renderNav targeturl nodes = renderHtmlFragment $
ulist ! [theclass "nav"] << map (renderNavNode targeturl) nodes
renderNavNode :: String -> NavNode -> Html
renderNavNode targeturl (NavPage tit pageurl) =
li ! attrs << hotlink pageurl' << tit
where targetdir = takeUrlDir targeturl
pageurl' = relUrl targetdir pageurl
attrs = if pageurl == targeturl
then [theclass "current"]
else []
renderNavNode targeturl (NavMenu tit nodes) =
li ! attrs << [ toHtml $ hotlink "#" << (tit ++ " »")
, ulist ! attrs << map (renderNavNode targeturl) nodes ]
where active = targeturl `isInNavNodes` nodes
attrs = if active then [theclass "active"] else []
isInNavNodes u = any (isInNavNode u)
isInNavNode u (NavPage _ u') = u == u'
isInNavNode u (NavMenu _ ns) = u `isInNavNodes` ns
formatFromExtension :: FilePath -> Format
formatFromExtension f = case (map toLower $ takeExtension f) of
".html" -> HtmlFormat
".xhtml" -> HtmlFormat
".latex" -> LaTeXFormat
".tex" -> LaTeXFormat
".context" -> ConTeXtFormat
".1" -> ManFormat
".rtf" -> RTFFormat
".texi" -> TexinfoFormat
".db" -> DocBookFormat
".fodt" -> OpenDocumentFormat
".txt" -> PlainFormat
".markdown" -> PlainFormat
_ -> HtmlFormat
renderPage :: Site -> Page -> IO String
renderPage site page = do
let menuHtml = renderNav (pageUrl page) (navigation site)
let layout = fromMaybe (defaultLayout site) $ layoutFile page
srcDirs <- mapM canonicalizePath $ sourceDir site
gs <- mapM directoryGroupRecursive srcDirs
let g = foldl1 mergeSTGroups gs
attrs <- forM (pageData page) $ \(k, v) -> getData site v >>= \n -> return (k,n)
todaysDate <- liftM utctDay getCurrentTime
let root' = case length (filter (=='/') $ pageUrl page) of
0 -> ""
n -> concat $ replicate n "../"
rawContents <-
case sourceFile page of
SourceFile sf -> liftM (filter (/='\r')) $ searchPath srcDirs sf >>= readFile
TemplateFile tf -> do
templ <- getTemplate tf g
return $ render
. setManyAttrib attrs
. setAttribute "root" root'
. setAttribute "gendate" todaysDate
$ templ
layoutTempl <- getTemplate layout g
let format = formatFromExtension (stripStExt layout)
let contents = converterForFormat format rawContents
return $ render
. setManyAttrib attrs
. setAttribute "sitetitle" (siteTitle site)
. setAttribute "pagetitle" (pageTitle page)
. setAttribute "gendate" todaysDate
. setAttribute "contents" contents
. setAttribute "root" root'
. setAttribute "nav" menuHtml
$ layoutTempl
converterForFormat :: Format -> String -> String
converterForFormat f =
let reader = readMarkdown defaultParserState{stateSmart = True}
in case f of
HtmlFormat -> writeHtmlString defaultWriterOptions . reader
LaTeXFormat -> writeLaTeX defaultWriterOptions . reader
PlainFormat -> id
ConTeXtFormat -> writeConTeXt defaultWriterOptions . reader
ManFormat -> writeMan defaultWriterOptions . reader
RTFFormat -> writeRTF defaultWriterOptions . reader
DocBookFormat -> writeDocbook defaultWriterOptions . reader
TexinfoFormat -> writeTexinfo defaultWriterOptions . reader
OpenDocumentFormat -> writeOpenDocument defaultWriterOptions . reader
getTemplate :: Stringable a => String -> STGroup a -> IO (StringTemplate a)
getTemplate templateName templateGroup = do
let template = case getStringTemplate (stripStExt templateName) templateGroup of
Just pt -> pt
Nothing -> error $ "Could not load template: " ++ templateName
case checkTemplate template of
(Just parseErrors, _, _ ) -> errorExit 17 $ "Error in template '" ++ templateName ++
"': " ++ parseErrors
(_, _, Just templatesNotFound) -> errorExit 21 $ "Templates referenced in template '" ++ templateName ++
"' not found: " ++ (intercalate ", " templatesNotFound)
(_, _, _) -> return ()
return template