{-# LANGUAGE OverloadedStrings, RankNTypes, StandaloneDeriving, FlexibleInstances #-} import Hakyll import Data.Monoid (Monoid(..), mconcat, (<>)) import Control.Monad (liftM, forM_, (<=<)) import Data.Char (toLower, isSpace, isAlphaNum) import Data.Maybe (mapMaybe, fromMaybe) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set import Data.List (take, reverse, nub, groupBy, concatMap, intersperse) import Data.Function (on) import Data.Default import Text.Pandoc import Text.Pandoc.Walk (query, walkM) import Text.Pandoc.Error import Control.Applicative (Alternative(..), Applicative(..)) import Text.Blaze.Html (toHtml, toValue, (!)) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A import System.FilePath (takeBaseName, (), (<.>)) import qualified Crypto.Hash.SHA256 as SHA256 (hash) import qualified Data.ByteString.Char8 as CBS import Data.Hex (hex) import Data.Char (toLower) import Tex (compileTex) import Text.Printf (printf) main :: IO () main = hakyllWith config $ do match "templates/*" $ compile templateCompiler match "css/*" $ do route idRoute compile copyFileCompiler tex <- getTex "posts/**" texTranslation' forM_ tex $ \(_, texStr) -> create [texTranslation' texStr] $ do route idRoute compile $ do item <- makeItem texStr >>= loadAndApplyTemplate "templates/preview.tex" defaultContext >>= withItemBody (unsafeCompiler . compileTex) saveSnapshot "alignment" $ fmap snd item return $ fmap fst item tags <- buildTags "posts/**" tagTranslation' >>= addTag "All Posts" "posts/**" match "posts/**" $ do route $ setExtension ".html" compile $ do let ctx = mconcat [ defaultContext , dateField "published" "%F" , tagsFieldWith getTags (\tag _ -> Just . H.li $ H.a ! A.href (toValue . toUrl $ "tags" tagTranslation tag <.> "html") $ toHtml tag) (mconcat . intersperse "\n") "tagList" tags ] getResourceBody >>= saveSnapshot "content" pandocCompilerWithTransformM defaultHakyllReaderOptions defaultHakyllWriterOptions texTransform >>= loadAndApplyTemplate "templates/default.html" ctx >>= relativizeUrls tagsRules tags $ \tag pattern -> do route idRoute compile $ do let ctx = mconcat [ constField "title" tag , listField "posts" defaultContext $ chronological =<< loadAll pattern , constField "rss" $ "/rss" tagTranslation tag <.> "rss" , defaultContext ] makeItem "" >>= loadAndApplyTemplate "templates/post-list.html" ctx >>= loadAndApplyTemplate "templates/default.html" ctx >>= relativizeUrls let tags' = tags { tagsMakeId = fromFilePath . (\b -> "rss" b <.> "rss") . takeBaseName . toFilePath . tagsMakeId tags} tagsRules tags' $ \tag pattern -> do route idRoute compile $ do let feedCtx = mconcat [ bodyField "description" , defaultContext ] renderRss (feedConfig tag) feedCtx =<< loadAllSnapshots pattern "content" create ["index.html"] $ rulesExtraDependencies [tagsDependency tags] $ do route idRoute -- $ setExtension ".html" compile $ do let ctx = mconcat [ listField "tags" defaultContext $ mapM (\(k, _) -> renderTag k tags) $ tagsMap tags , constField "title" "Index" , constField "rss" "/rss/all-posts.rss" , defaultContext ] {-item <- getResourceBody pandocCompilerWith def (def { writerEmailObfuscation = NoObfuscation }) >>=-} makeItem "" >>= loadAndApplyTemplate "templates/index.html" ctx >>= loadAndApplyTemplate "templates/default.html" ctx >>= relativizeUrls deriving instance Eq (Item String) feedConfig :: String -> FeedConfiguration feedConfig tagName = FeedConfiguration { feedTitle = "dirty-haskell.org: " ++ tagName , feedDescription = "dirty-haskell.org — A Blog." , feedAuthorName = "G. Kleen" , feedAuthorEmail = "blog@dirty-haskell.org" , feedRoot = "https://dirty-haskell.org" } renderTag :: String -- ^ Tag name -> Tags -> Compiler (Item String) renderTag tag tags = do ellipsisItem <- makeItem "" let ids = fromMaybe [] $ lookup tag $ tagsMap tags postCtx = mconcat [ listField "posts" (ellipsisContext ellipsisItem) $ liftM (withEllipsis ellipsisItem) $ chronological =<< mapM load ids , constField "title" tag , constField "rss" ("rss" tagTranslation tag <.> "rss") , constField "url" ("tags" tagTranslation tag <.> "html") , defaultContext ] makeItem "" >>= loadAndApplyTemplate "templates/post-list.html" postCtx >>= loadAndApplyTemplate "templates/tag.html" postCtx where ellipsisContext item = mconcat [ boolField "ellipsis" (== item) , defaultContext ] boolField name f = field name (\i -> if f i then pure (error $ unwords ["no string value for bool field:",name]) else empty) withEllipsis ellipsisItem xs | length xs > max = ellipsisItem : takeEnd (max - 1) xs | otherwise = xs takeEnd i = reverse . take i . reverse max = 4 tagTranslation' :: String -> Identifier tagTranslation' = fromCapture "tags/*.html" . tagTranslation tagTranslation :: String -> String tagTranslation = mapMaybe charTrans where charTrans c | isSpace c = Just '-' | isAlphaNum c = Just $ toLower c | otherwise = Nothing addTag :: MonadMetadata m => String -> Pattern -> Tags -> m Tags addTag name pattern tags = do ids <- getMatches pattern return $ tags { tagsMap = tagsMap tags ++ [(name, ids)] } texTranslation' :: String -> Identifier texTranslation' = fromCapture "tex/*.svg" . map toLower . CBS.unpack . hex . SHA256.hash . CBS.pack getTex :: Pattern -> (String -> Identifier) -> Rules [([Identifier], String)] getTex pattern makeId = do ids <- getMatches pattern texStrs <- concat `liftM` mapM (\id -> map ((,) [id]) `liftM` getTex' (toFilePath' id)) ids return $ mergeGroups $ groupBy ((==) `on` snd) $ texStrs where getTex' :: FilePath -> Rules [String] getTex' path = preprocess . fmap concat $ (\x -> [query extractTex, query extractTex'] <*> pure x) `liftM` readPandoc' path extractTex :: Inline -> [String] extractTex (Math _ str) = ["\\(" ++ str ++ "\\)"] extractTex (RawInline "latex" str) = [str] extractTex _ = [] extractTex' :: Block -> [String] extractTex' (RawBlock "latex" str) = [str] extractTex' _ = [] mergeGroups :: [[([Identifier], String)]] -> [([Identifier], String)] mergeGroups = map mergeGroups' . filter (not . null) mergeGroups' :: [([Identifier], String)] -> ([Identifier], String) mergeGroups' xs@((_, str):_) = (concatMap fst xs, str) readPandoc' :: FilePath -> IO Pandoc readPandoc' path = readFile path >>= either fail return . result' where result' str = case result str of Left (ParseFailure err) -> Left $ "parse failed: " ++ err Left (ParsecError _ err) -> Left $ "parse failed: " ++ show err Right item' -> Right item' result str = reader defaultHakyllReaderOptions (fileType path) str reader ro t = case t of DocBook -> readDocBook ro Html -> readHtml ro LaTeX -> readLaTeX ro LiterateHaskell t' -> reader (addExt ro Ext_literate_haskell) t' Markdown -> readMarkdown ro MediaWiki -> readMediaWiki ro OrgMode -> readOrg ro Rst -> readRST ro Textile -> readTextile ro _ -> error $ "I don't know how to read a file of " ++ "the type " ++ show t ++ " for: " ++ path addExt ro e = ro {readerExtensions = Set.insert e $ readerExtensions ro} texTransform :: Pandoc -> Compiler Pandoc texTransform = walkM texTransformInline <=< walkM texTransformBlock where texTransformInline :: Inline -> Compiler Inline texTransformInline (Math mathType tex) = (\html -> Span ("", [classOf mathType], []) [RawInline "html" html]) <$> texTransform' ("\\(" ++ tex ++ "\\)") texTransformInline (RawInline "latex" tex) = (\html -> Span ("", [], []) [RawInline "html" html]) <$> texTransform' tex texTransformInline x = return x texTransformBlock :: Block -> Compiler Block texTransformBlock (RawBlock "latex" tex) = (\html -> Div ("", [], []) [RawBlock "html" html]) <$> texTransform' tex texTransformBlock x = return x texTransform' :: String -> Compiler String texTransform' tex = do let texId = texTranslation' tex alignment <- loadSnapshotBody texId "alignment" return $ printf "%s" (toFilePath texId) (alignment :: String) tex classOf DisplayMath = "display-math" classOf InlineMath = "inline-math" toFilePath' :: Identifier -> FilePath toFilePath' = (providerDirectory config ) . toFilePath config :: Configuration config = defaultConfiguration { providerDirectory = "provider" , deployCommand = "rsync -av --progress -c --delete-delay -m _site/ gkleen@ymir.yggdrasil.li:/srv/www/dirty-haskell.org/" }