Permalink
Fetching contributors…
Cannot retrieve contributors at this time
170 lines (154 sloc) 6.95 KB
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-}
{-
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 Lucid
import Data.Char
import Data.List (intercalate)
import Data.List.Split (wordsBy)
import Text.StringTemplate
import Data.Text.Lazy (unpack)
import Data.Text (pack)
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
#if MIN_VERSION_pandoc(1,14,0)
import Text.Pandoc.Error (handleError)
#else
handleError :: Pandoc -> Pandoc
handleError = id
#endif
-- | @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 = unpack $ renderText $
ul_ [class_ "nav tree"] $ mapM_ (renderNavNode targeturl) nodes
renderNavNode :: String -> NavNode -> Html ()
renderNavNode targeturl (NavPage tit pageurl) =
li_ [class_ "current" | pageurl == targeturl] (a_ [href_ pageurl'] (toHtml tit))
where targetdir = takeUrlDir targeturl
pageurl' = pack $ relUrl targetdir pageurl
renderNavNode targeturl (NavMenu tit nodes) = li_ [] $
do a_ [class_ "tree-toggle nav-header"] (toHtml tit)
ul_ [class_ "nav tree"] (mapM_ (renderNavNode targeturl) nodes)
where active = targeturl `isInNavNodes` nodes
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 ("../" :: String)
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 = handleError . readMarkdown def{readerSmart = True}
in case f of
HtmlFormat -> writeHtmlString def{ writerHtml5 = True } . reader
LaTeXFormat -> writeLaTeX def . reader
PlainFormat -> id
ConTeXtFormat -> writeConTeXt def . reader
ManFormat -> writeMan def . reader
RTFFormat -> writeRTF def . reader
DocBookFormat -> writeDocbook def . reader
TexinfoFormat -> writeTexinfo def . reader
OpenDocumentFormat -> writeOpenDocument def . 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