summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--blog.cabal1
-rw-r--r--src/Site.hs66
2 files changed, 64 insertions, 3 deletions
diff --git a/blog.cabal b/blog.cabal
index a493c15..f1e3c0b 100644
--- a/blog.cabal
+++ b/blog.cabal
@@ -24,5 +24,6 @@ executable site
24 , hakyll >=4.6 && <5 24 , hakyll >=4.6 && <5
25 , containers >=0.5 && <0.6 25 , containers >=0.5 && <0.6
26 , pandoc >=1.13 && <2 26 , pandoc >=1.13 && <2
27 , pandoc-types >=1.12 && <2
27 , data-default >=0.5 && <0.6 28 , data-default >=0.5 && <0.6
28 , filepath >=1.3 && <2 29 , filepath >=1.3 && <2
diff --git a/src/Site.hs b/src/Site.hs
index 25d11d0..279532f 100644
--- a/src/Site.hs
+++ b/src/Site.hs
@@ -3,14 +3,18 @@
3import Hakyll 3import Hakyll
4 4
5import Data.Monoid (Monoid(..), mconcat, (<>)) 5import Data.Monoid (Monoid(..), mconcat, (<>))
6import Control.Monad (liftM) 6import Control.Monad (liftM, forM_)
7import Data.Char (toLower, isSpace, isAlphaNum) 7import Data.Char (toLower, isSpace, isAlphaNum)
8import Data.Maybe (mapMaybe, fromMaybe) 8import Data.Maybe (mapMaybe, fromMaybe)
9import Data.Map (Map) 9import Data.Map (Map)
10import qualified Data.Map as Map 10import qualified Data.Map as Map
11import Data.List (take, reverse) 11import qualified Data.Set as Set
12import Data.List (take, reverse, nub, groupBy, concatMap)
13import Data.Function (on)
12import Data.Default 14import Data.Default
13import Text.Pandoc.Options (WriterOptions(..), ObfuscationMethod(..)) 15import Text.Pandoc
16import Text.Pandoc.Walk (query)
17import Text.Pandoc.Error
14import Control.Applicative (Alternative(..), Applicative(..)) 18import Control.Applicative (Alternative(..), Applicative(..))
15 19
16import System.FilePath (takeBaseName, (</>), (<.>)) 20import System.FilePath (takeBaseName, (</>), (<.>))
@@ -31,6 +35,14 @@ main = hakyllWith config $ do
31 >>= loadAndApplyTemplate "templates/default.html" defaultContext 35 >>= loadAndApplyTemplate "templates/default.html" defaultContext
32 >>= relativizeUrls 36 >>= relativizeUrls
33 37
38 math <- getMath "posts/*" mathTranslation'
39 forM_ math $ \(deps, mathStr) ->
40 rulesExtraDependencies (map IdentifierDependency deps) $
41 create [mathTranslation' mathStr] $ do
42 route idRoute
43 compile $ do
44 makeItem $ mathStr
45
34 tags <- buildTags "posts/*" tagTranslation' >>= addTag "All Posts" "posts/*" 46 tags <- buildTags "posts/*" tagTranslation' >>= addTag "All Posts" "posts/*"
35 47
36 tagsRules tags $ \tag pattern -> do 48 tagsRules tags $ \tag pattern -> do
@@ -122,11 +134,59 @@ tagTranslation = mapMaybe charTrans
122 | isAlphaNum c = Just $ toLower c 134 | isAlphaNum c = Just $ toLower c
123 | otherwise = Nothing 135 | otherwise = Nothing
124 136
137mathTranslation' :: String -> Identifier
138mathTranslation' = fromCapture "math/*.svg" . id -- TODO hash math
139
125addTag :: MonadMetadata m => String -> Pattern -> Tags -> m Tags 140addTag :: MonadMetadata m => String -> Pattern -> Tags -> m Tags
126addTag name pattern tags = do 141addTag name pattern tags = do
127 ids <- getMatches pattern 142 ids <- getMatches pattern
128 return $ tags { tagsMap = tagsMap tags ++ [(name, ids)] } 143 return $ tags { tagsMap = tagsMap tags ++ [(name, ids)] }
129 144
145getMath :: Pattern -> (String -> Identifier) -> Rules [([Identifier], String)]
146getMath pattern makeId = do
147 ids <- getMatches pattern
148 mathStrs <- concat `liftM` mapM (\id -> map ((,) [id]) `liftM` getMath' (toFilePath' id)) ids
149 return $ mergeGroups $ groupBy ((==) `on` snd) $ mathStrs
150 where
151 getMath' :: FilePath -> Rules [String]
152 getMath' path = preprocess (query extractMath `liftM` readPandoc' path)
153 extractMath :: Inline -> [String]
154 extractMath (Math _ str) = [str]
155 extractMath _ = []
156 mergeGroups :: [[([Identifier], String)]] -> [([Identifier], String)]
157 mergeGroups = map mergeGroups' . filter (not . null)
158 mergeGroups' :: [([Identifier], String)] -> ([Identifier], String)
159 mergeGroups' xs@((_, str):_) = (concatMap fst xs, str)
160
161readPandoc' :: FilePath -> IO Pandoc
162readPandoc' path = readFile path >>= either fail return . result'
163 where
164 result' str = case result str of
165 Left (ParseFailure err) -> Left $
166 "parse failed: " ++ err
167 Left (ParsecError _ err) -> Left $
168 "parse failed: " ++ show err
169 Right item' -> Right item'
170 result str = reader defaultHakyllReaderOptions (fileType path) str
171 reader ro t = case t of
172 DocBook -> readDocBook ro
173 Html -> readHtml ro
174 LaTeX -> readLaTeX ro
175 LiterateHaskell t' -> reader (addExt ro Ext_literate_haskell) t'
176 Markdown -> readMarkdown ro
177 MediaWiki -> readMediaWiki ro
178 OrgMode -> readOrg ro
179 Rst -> readRST ro
180 Textile -> readTextile ro
181 _ -> error $
182 "I don't know how to read a file of " ++
183 "the type " ++ show t ++ " for: " ++ path
184
185 addExt ro e = ro {readerExtensions = Set.insert e $ readerExtensions ro}
186
187toFilePath' :: Identifier -> FilePath
188toFilePath' = (providerDirectory config </>) . toFilePath
189
130config :: Configuration 190config :: Configuration
131config = defaultConfiguration { providerDirectory = "provider" 191config = defaultConfiguration { providerDirectory = "provider"
132 , deployCommand = "rsync -av --progress -c --delete-delay -m _site/ gkleen@surtr.yggdrasil.li:/var/www/dirty-haskell.org/" 192 , deployCommand = "rsync -av --progress -c --delete-delay -m _site/ gkleen@surtr.yggdrasil.li:/var/www/dirty-haskell.org/"