blob: dc86b695fc36ee1d7632c816f004225330f14015 (
plain)
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
|
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
import Control.Arrow (second)
import Control.Monad (filterM, forM_)
import Data.List (isPrefixOf, sortBy)
import Data.Ord (comparing)
import Hakyll
import System.Directory (copyFile)
import System.FilePath (dropTrailingPathSeparator, splitPath)
import qualified Text.Pandoc as Pandoc
--------------------------------------------------------------------------------
main :: IO ()
main = hakyllWith config $ do
-- Copy CHANGELOG.md here.
preprocess $ copyFile "../CHANGELOG.md" "releases.markdown"
-- CSS
match "css/*" $ do
route idRoute
compile compressCssCompiler
-- Static directories
forM_ ["images/*", "examples/*"] $ \f -> match f $ do
route idRoute
compile copyFileCompiler
-- Haddock stuff
match "reference/**.html" $ do
route idRoute
compile $ fmap (withUrls hackage) <$> getResourceString
-- Haddock stuff
match ("reference/**" `mappend` complement "**.html") $ do
route idRoute
compile copyFileCompiler
-- Pages
match "*.markdown" $ do
route $ setExtension "html"
compile $ pandocCompiler
>>= loadAndApplyTemplate "templates/default.html" defaultContext
>>= relativizeUrls
-- Tutorials
match "tutorials/*" $ do
route $ setExtension "html"
compile $ pandocCompilerWith defaultHakyllReaderOptions withToc
>>= loadAndApplyTemplate "templates/tutorial.html" defaultContext
>>= loadAndApplyTemplate "templates/default.html" defaultContext
>>= relativizeUrls
-- Tutorial list
create ["tutorials.html"] $ do
route idRoute
compile $ do
ctx <- tutorialsCtx <$>
sortBy (comparing itemIdentifier) <$> loadAll "tutorials/*"
makeItem ""
>>= loadAndApplyTemplate "templates/tutorials.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
-- Templates
match "templates/*" $ compile templateCompiler
where
withToc = defaultHakyllWriterOptions
{ Pandoc.writerTableOfContents = True
, Pandoc.writerTemplate = Just tocTemplate
}
-- When did it get so hard to compile a string to a Pandoc template?
tocTemplate =
either error id $ either (error . show) id $
Pandoc.runPure $ Pandoc.runWithDefaultPartials $
Pandoc.compileTemplate "" "$toc$\n$body$"
--------------------------------------------------------------------------------
config :: Configuration
config = defaultConfiguration
{ deployCommand = "rsync --checksum -ave 'ssh -p 2222' \
\_site/* \
\jaspervdj@jaspervdj.be:jaspervdj.be/hakyll/"
}
--------------------------------------------------------------------------------
-- | Turns
--
-- > /usr/share/doc/ghc/html/libraries/base-4.6.0.0/Data-String.html
--
-- into
--
-- > http://hackage.haskell.org/packages/archive/base/4.6.0.0/doc/html/Data-String.html
hackage :: String -> String
hackage url
| "/usr" `isPrefixOf` url =
"http://hackage.haskell.org/packages/archive/" ++
packageName ++ "/" ++ version' ++ "/doc/html/" ++ baseName
| otherwise = url
where
(packageName, version') = second (drop 1) $ break (== '-') package
(baseName : package : _) = map dropTrailingPathSeparator $
reverse $ splitPath url
--------------------------------------------------------------------------------
-- | Partition tutorials into tutorial series, other articles, external articles
tutorialsCtx :: [Item String] -> Context String
tutorialsCtx tuts =
constField "title" "Tutorials" <>
listField "main" defaultContext (ofType "main") <>
listField "articles" defaultContext (ofType "article") <>
listField "externals" defaultContext (ofType "external") <>
listField "robertwpearce" defaultContext (ofType "robertwpearce") <>
defaultContext
where
ofType ty = filterM (\item -> do
mbType <- getMetadataField (itemIdentifier item) "type"
return $ Just ty == mbType) tuts
|
