190 lines
6.0 KiB
Haskell
190 lines
6.0 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
import Control.DeepSeq (rnf)
|
|
import Control.Concurrent
|
|
import Control.Exception
|
|
import Control.Monad
|
|
|
|
import qualified Data.ByteString.Lazy.Char8 as BS
|
|
import Data.ByteString.Lazy.Char8 (pack, unpack)
|
|
import qualified Data.Text.Encoding as T
|
|
import qualified Data.HashMap.Strict as HMap
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Text as T
|
|
import Data.Functor
|
|
import Data.Monoid
|
|
import Data.Aeson
|
|
import Data.Maybe
|
|
import Data.List
|
|
import Data.Char
|
|
|
|
import Debug.Trace
|
|
|
|
import Hakyll.Core.Compiler.Internal
|
|
import Hakyll.Core.Compiler
|
|
import Hakyll.Web.Sass
|
|
import Hakyll
|
|
|
|
import qualified Network.URI.Encode as URI (encode)
|
|
|
|
import qualified Skylighting as Sky
|
|
|
|
import System.Environment
|
|
import System.Process
|
|
import System.Exit
|
|
import System.IO
|
|
|
|
import Text.Pandoc.Walk (query, walkM)
|
|
import Text.Pandoc.Highlighting
|
|
import Text.Pandoc.Definition
|
|
import Text.Pandoc.Options
|
|
import Text.Sass.Functions
|
|
|
|
readerOpts :: ReaderOptions
|
|
readerOpts = def { readerExtensions = pandocExtensions
|
|
, readerIndentedCodeClasses = ["amulet"] }
|
|
|
|
writerOptions :: Compiler WriterOptions
|
|
writerOptions = do
|
|
syntaxMap <- loadAllSnapshots "syntax/*.xml" "syntax"
|
|
<&> foldr (Sky.addSyntaxDefinition . itemBody) Sky.defaultSyntaxMap
|
|
|
|
pure $ defaultHakyllWriterOptions
|
|
{ writerExtensions = extensionsFromList
|
|
[ Ext_tex_math_dollars
|
|
, Ext_tex_math_double_backslash
|
|
, Ext_latex_macros
|
|
] <> writerExtensions defaultHakyllWriterOptions
|
|
, writerSyntaxMap = syntaxMap
|
|
, writerHighlightStyle = Just kate
|
|
}
|
|
|
|
rssfeed :: FeedConfiguration
|
|
rssfeed
|
|
= FeedConfiguration { feedTitle = "Abigail's Blag: Latest articles"
|
|
, feedDescription = ""
|
|
, feedAuthorName = "Abigail Magalhães"
|
|
, feedAuthorEmail = "magalhaes.alcantara@pucpr.edu.br"
|
|
, feedRoot = "https://abby.how"
|
|
}
|
|
|
|
conf :: Configuration
|
|
conf = def { destinationDirectory = ".site"
|
|
, storeDirectory = ".store"
|
|
, tmpDirectory = ".store/tmp"
|
|
, deployCommand = "./sync" }
|
|
|
|
main :: IO ()
|
|
main = hakyllWith conf $ do
|
|
let compiler = do
|
|
wops <- writerOptions
|
|
pandocCompilerWithTransformM readerOpts wops pure
|
|
|
|
match "static/*" $ do
|
|
route idRoute
|
|
compile copyFileCompiler
|
|
|
|
match "css/*.scss" $ do
|
|
route $ setExtension "css"
|
|
compile $ sassCompilerWith def { sassOutputStyle = SassStyleCompressed
|
|
, sassImporters = Nothing
|
|
}
|
|
|
|
match "pages/**/*" $ do
|
|
route $ setExtension "html"
|
|
|
|
compile $ do
|
|
id <- getUnderlying
|
|
meta <- getMetadata id
|
|
let category = takeWhile (/= '/') $ tail $ dropWhile (/= '/') (toFilePath id)
|
|
compiler
|
|
>>= loadAndApplyTemplate (fromFilePath ("templates/" ++ category ++ ".html")) (metaToContext meta)
|
|
>>= saveSnapshot "content"
|
|
|
|
match "pages/*.html" $ do
|
|
route $ gsubRoute "pages/" (const "")
|
|
compile $ do
|
|
ppl <- loadAll "pages/people/*"
|
|
let (ppl_a, ppl_b) = explode ppl
|
|
|
|
projects <- loadAll "pages/projects/*"
|
|
|
|
let indexCtx =
|
|
listField "people-1" postCtx (return ppl_a) <>
|
|
listField "people-2" postCtx (return ppl_b) <>
|
|
listField "projects" postCtx (return projects) <>
|
|
constField "title" "Home" <>
|
|
defaultContext
|
|
getResourceBody
|
|
>>= applyAsTemplate indexCtx
|
|
>>= loadAndApplyTemplate "templates/default.html" indexCtx
|
|
>>= relativizeUrls
|
|
|
|
match "pages/*.md" $ do
|
|
route $ gsubRoute "pages/" (const "") <> setExtension "html"
|
|
compile $ compiler
|
|
>>= loadAndApplyTemplate "templates/default.html" defaultContext
|
|
>>= relativizeUrls
|
|
|
|
match "templates/*" $ compile templateBodyCompiler
|
|
|
|
postCtx :: Context String
|
|
postCtx = dateField "date" "%B %e, %Y"
|
|
<> defaultContext
|
|
|
|
pathFromTitle :: Metadata -> Routes
|
|
pathFromTitle meta =
|
|
let
|
|
declaredCategory =
|
|
case lookupString "category" meta of
|
|
Just s -> ((s ++ "/") ++)
|
|
Nothing -> ("posts/" <>)
|
|
|
|
!titleString =
|
|
case lookupString "title" meta of
|
|
Just s -> s
|
|
Nothing -> error "post has no title?"
|
|
|
|
title = filter (/= "") . map (filter isAlphaNum . map toLower) . words $ titleString
|
|
|
|
(category, title') =
|
|
if | "or" `elem` title -> (declaredCategory, takeWhile (/= "or") title)
|
|
| ["a", "quickie"] `isPrefixOf` title -> (("quick/" ++), drop 2 title)
|
|
| otherwise -> (declaredCategory, title)
|
|
in
|
|
case lookupString "path" meta of
|
|
Just p -> constRoute (category (p <> ".html"))
|
|
Nothing -> constRoute (category (intercalate "-" title' <> ".html"))
|
|
|
|
foldMapM :: (Monad w, Monoid m, Foldable f) => (a -> w m) -> f a -> w m
|
|
foldMapM k = foldr (\x y -> do { m <- k x; (m <>) <$> y }) (pure mempty)
|
|
|
|
explode :: [a] -> ([a], [a])
|
|
explode = go True where
|
|
go True (x:xs) =
|
|
let (as, bs) = go False xs
|
|
in (x:as, bs)
|
|
go False (x:xs) =
|
|
let (as, bs) = go True xs
|
|
in (as, x:bs)
|
|
go _ [] = ([], [])
|
|
|
|
metaToContext :: Object -> Context String
|
|
metaToContext obj = HMap.foldrWithKey go mempty obj <> defaultContext where
|
|
go :: T.Text -> Value -> Context String -> Context String
|
|
go key (String x) ctx = constField (T.unpack key) (T.unpack x) <> ctx
|
|
go key (Array xs) ctx = listField (T.unpack key) (Context jsonContext) (traverse makeItem (foldr (:) [] xs))
|
|
|
|
jsonContext key idk item = do
|
|
let x = itemBody item
|
|
objToField key x
|
|
|
|
objToField key x =
|
|
case x of
|
|
String x -> pure $ StringField (T.unpack x)
|
|
Object m -> objToField (tail (dropWhile (/= '.') key)) (fromJust (HMap.lookup (T.pack (takeWhile (/= '.') key)) m))
|
|
Array xs -> do
|
|
is <- traverse makeItem (foldr (:) [] xs)
|
|
pure $ ListField (Context jsonContext) is |