Commit 5cbf01d2 authored by Nicolas Lenz's avatar Nicolas Lenz

Complete refactor and restructure. It's way prettier now!

parent 5d86d723
Pipeline #240 passed with stage
in 24 minutes and 17 seconds
......@@ -25,6 +25,7 @@ dependencies:
- containers # For Map
- yaml
- process
- exceptions
default-extensions:
- NoImplicitPrelude
......@@ -34,7 +35,7 @@ default-extensions:
executables:
nebelhorn:
main: main.hs
main: Main.hs
source-dirs: src
ghc-options:
- -Wall
......
{-# LANGUAGE QuasiQuotes #-}
module Build (build) where
import ClassyPrelude hiding ((</>))
import Config
import File
import Path
import System.Process
import Text.Pandoc
import qualified Data.Map as Map
{- |
A handy nested map function. Works just like the normal inline map '<$>', but nested.
Example: @(+1) <$$> [[1, 2], [3, 4]]@ evaluates to @[[2, 3], [4, 5]]@.
-}
(<$$>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)
(<$$>) = fmap . fmap
-- | The monadic equivalent of the nested map '<$$>'.
mapMT :: (Traversable t1, Traversable t2, Monad m) => (a -> m b) -> t1 (t2 a) -> m (t1 (t2 b))
mapMT = mapM . mapM
import Text.Pandoc.Definition
import Text.Pandoc.Class
import Definition
import Util
import Config
import Load
import Save
-- | Generate the Pandoc MetaValue for a navbar from a list of NavItem from a Nebelhorn config.
generateNavbarMeta :: [NavItem] -> MetaValue
......@@ -28,87 +16,48 @@ generateNavbarMeta navItems = MetaList $ map f navItems where
f NavItem{..} = MetaMap $ Map.fromList
[("name", MetaString $ unpack navItemName), ("link", MetaString $ unpack navItemLink)]
-- | Reads in a single document to a Pandoc value using an extra Meta.
read :: (PandocMonad m, MonadIO m) => Meta -> (Path Rel File, Text) -> m (Path Rel File, Pandoc)
read (Meta extraMetaMap) (path, content) = do
contentR <- read' content
-- TODO: This should really be done without IO...
newPath <- liftIO $ setFileExtension ".html" path
return (newPath, addMeta (Meta $ Map.insert "link" (MetaString $ unpack $ toFilePath newPath) extraMetaMap) contentR)
where read' = readMarkdown $ def {readerExtensions = pandocExtensions}
-- | Writes a single Pandoc document to HTML5 output using a template.
write :: (PandocMonad m) => Text -> Pandoc -> m Text
write template = writeHtml5String writerOptions where
writerOptions = def
{writerExtensions = pandocExtensions, writerTemplate = Just $ unpack template}
-- | Builds a list of pages, using a MetaValue for the navbar, from raw markdown to HTML5.
buildPages :: (PandocMonad m, MonadIO m)
=> MetaValue -> [(Path Rel File, Text)] -> m [(Path Rel File, Text)]
buildPages navbar inputs = do
template <- readFileUtf8 "template/page.html"
pagesInput <- read extraMeta `mapM` inputs
write template `mapMT` pagesInput
where
extraMeta = Meta $ Map.fromList [("navbar", navbar)]
-- | Builds a list of articles, using a MetaValue for the navbar, from raw markdown to HTML5.
buildArticles :: (PandocMonad m, MonadIO m)
=> MetaValue -> [(Path Rel File, Text)] -> m (Text, [(Path Rel File, Text)])
buildArticles navbar inputs = do
templateArticle <- readFileUtf8 "template/article.html"
templateIndex <- readFileUtf8 "template/index.html"
articlesInput' <- sortArticlesPlus <$> read extraMeta `mapM` inputs
let neighbors = getNeighbors $ snd <$> articlesInput'
-- TODO Refactor!
let articlesInput = map (\((prevM, nextM), (path, art)) -> (path, addMeta (Meta $ Map.fromList [("prev", fromMaybe (MetaString "") prevM), ("next", fromMaybe (MetaString "") nextM)]) art)) (zip neighbors articlesInput')
let indexInput = generateIndex extraMeta (snd <$> articlesInput)
articlesOutput <- write templateArticle `mapMT` articlesInput
indexOutput <- write templateIndex indexInput
return (indexOutput, articlesOutput)
where extraMeta = Meta $ Map.fromList [("navbar", navbar)]
putNavbar :: Nebelhorn -> Nebelhorn
putNavbar nebelhorn@Nebelhorn{..}
= nebelhorn{nebelhornArticles = addMeta "navbar" navbar <$> nebelhornArticles,
nebelhornPages = addMeta "navbar" navbar <$> nebelhornPages,
nebelhornIndex = addMeta "navbar" navbar nebelhornIndex} where
navbar = generateNavbarMeta nebelhornNavItems
-- | Gets the previous and next neigbors for each article in the list. This only works if every pandocument has the link meta value set.
getNeighbors :: [Pandoc] -> [(Maybe MetaValue, Maybe MetaValue)]
getNeighbors articles = f <$> [0..(length articles - 1)] where
-- Index + 1 is previous as the newest is first in the list
f n = (getLink =<< articles `safeIndex` (n+1), getLink =<< articles `safeIndex` (n-1))
f n = (getLinkMeta =<< articles `safeIndex` (n+1), getLinkMeta =<< articles `safeIndex` (n-1))
getLink :: Pandoc -> Maybe MetaValue
getLink (Pandoc meta _) = lookupMeta "link" meta
-- TODO replace with library function
-- | Safely retrieve an item from a list, returning Nothing on failure.
-- | Safely retrieve an item from a list, returning Nothing on failure. Mostly equivalent to Data.Key.lookup, but returns Nothing on negative numbers which I rely on.
safeIndex :: [a] -> Int -> Maybe a
safeIndex [] _ = Nothing
safeIndex _ n | n < 0 = Nothing
safeIndex (x:_) 0 = Just x
safeIndex (_:xs) n = safeIndex xs (n-1)
-- | Generate an index page from a list of Articles.
-- Expects each article to contain a meta value "link" with its link path.
generateIndex :: Meta -> [Pandoc] -> Pandoc
generateIndex extraMeta = generateIndex' {- . sortArticles -} where -- Sorting is done right at the beginning now
generateIndex' articles = Pandoc metaOutput [] where
metaOutput = extraMeta <> Meta (Map.fromList
[("pagetitle", MetaString "Home"), ("articles", MetaList articlesOutput)])
articlesOutput = generateIndexMeta <$> articles
getLinkMeta :: Pandoc -> Maybe MetaValue
getLinkMeta (Pandoc meta _) = lookupMeta "link" meta
putNeighbors :: Nebelhorn -> Nebelhorn
putNeighbors nebelhorn@Nebelhorn{..}
= nebelhorn{nebelhornArticles = uncurry insertNeighbors <$> zip (getNeighbors nebelhornArticles) nebelhornArticles} where
insertNeighbors :: (Maybe MetaValue, Maybe MetaValue) -> Pandoc -> Pandoc
insertNeighbors (prevM, nextM)
= addMeta "prev" (fromMaybe (MetaString "") prevM)
. addMeta "next" (fromMaybe (MetaString "") nextM)
putIndex :: Nebelhorn -> Nebelhorn
putIndex nebelhorn@Nebelhorn{..} = nebelhorn
{ nebelhornIndex
= addMeta "pagetitle" (MetaString "Home")
. addMeta "articles" (MetaList $ generateIndexMeta <$> nebelhornArticles)
$ nebelhornIndex
}
-- TODO only plus is needed, refactor
-- | Sorts a list of pandocuments by their date meta values.
sortArticles :: [Pandoc] -> [Pandoc]
sortArticles = sortOn (Down . (\(Pandoc meta _) -> lookupMeta "date" meta))
sortArticlesPlus :: [(a, Pandoc)] -> [(a, Pandoc)]
sortArticlesPlus = sortOn (Down . (\(_, (Pandoc meta _)) -> lookupMeta "date" meta))
sortArticles :: Nebelhorn -> Nebelhorn
sortArticles nebelhorn@Nebelhorn{..} = nebelhorn{nebelhornArticles = sortOn (Down . (\(Pandoc meta _) -> lookupMeta "date" meta)) nebelhornArticles}
-- | Generates the Pandoc MetaMap for a document for the index page.
-- It contains the meta of the source, the link and the body.
......@@ -116,39 +65,5 @@ generateIndexMeta :: Pandoc -> MetaValue
generateIndexMeta (Pandoc (Meta metaMap) body) = MetaMap $ metaMap
<> Map.fromList [("body", MetaBlocks body)]
-- | Adds a Meta block to a pandocument. Already known keys are overwritten.
addMeta :: Meta -> Pandoc -> Pandoc
addMeta (Meta metaMapExtra) (Pandoc (Meta metaMap) blocks)
= Pandoc (Meta $ metaMapExtra `Map.union` metaMap) blocks
-- | Compile the stylesheet using sassc.
compileStylesheet :: IO ()
compileStylesheet = callCommand "sassc -m style/stylesheet.scss out/style/stylesheet.css"
build :: IO ()
build = loadConfig >>= \case
Left ex -> fail $ "Error while reading config: " <> show ex
Right Config{..} -> do
copyFolders configFoldersToCopy configOutputFolder
compileStylesheet
articlesInput <- prependPath <$$> load [reldir|article|]
pagesInput <- load [reldir|page|]
articlesOutputE <- runIO (buildArticles (generateNavbarMeta configNavbar) articlesInput)
pagesOutputE <- runIO (buildPages (generateNavbarMeta configNavbar) pagesInput)
let outputE = do{
(indexOutput, articlesOutput) <- articlesOutputE;
pagesOutput <- pagesOutputE;
return (indexOutput, articlesOutput, pagesOutput)}
case outputE of
Left ex -> fail $ "Error while processing articles: " <> show ex
Right (indexOutput, articlesOutput, pagesOutput) -> do
save configOutputFolder articlesOutput
save configOutputFolder pagesOutput
save configOutputFolder [([relfile|index.html|], indexOutput)]
putStrLn "Success!"
where prependPath (path, pandoc) = ([reldir|article|] </> path, pandoc)
build :: (PandocMonad m, MonadIO m) => Config -> m ()
build config = (putIndex . putNavbar . putNeighbors . sortArticles <$> load config) >>= save
......@@ -7,9 +7,12 @@ import Data.Yaml
import Path
data Config = Config {
configOutputFolder :: Path Rel Dir,
configArticleFolder :: Path Rel Dir,
configPageFolder :: Path Rel Dir,
configFolderOutput :: Path Rel Dir,
configFolderArticle :: Path Rel Dir,
configFolderPage :: Path Rel Dir,
configTemplateArticle :: Path Rel File,
configTemplatePage :: Path Rel File,
configTemplateIndex :: Path Rel File,
configFoldersToCopy :: [Path Rel Dir],
configNavbar :: [NavItem]
} deriving (Show)
......@@ -21,9 +24,12 @@ data NavItem = NavItem {
instance FromJSON Config where
parseJSON = withObject "Config" $ \v -> Config
<$> v .:? "outputFolder" .!= [reldir|out|]
<*> v .:? "articleFolder" .!= [reldir|article|]
<*> v .:? "pageFolder" .!= [reldir|page|]
<$> v .:? "folderOutput" .!= [reldir|out|]
<*> v .:? "folderArticle" .!= [reldir|article|]
<*> v .:? "folderPage" .!= [reldir|page|]
<*> v .:? "templateArticle" .!= [relfile|template/article.html|]
<*> v .:? "templatePage" .!= [relfile|template/page.html|]
<*> v .:? "templateIndex" .!= [relfile|template/index.html|]
<*> v .:? "foldersToCopy" .!= []
<*> v .:? "navbar" .!= [NavItem "Home" "/index.html"]
......
module Definition where
import ClassyPrelude
import Path
import Config
import Text.Pandoc.Definition
data Nebelhorn = Nebelhorn {
nebelhornFolderOutput :: Path Rel Dir,
nebelhornFoldersToCopy :: [Path Rel Dir],
nebelhornNavItems :: [NavItem],
nebelhornArticles :: [Pandoc],
nebelhornPages :: [Pandoc],
nebelhornIndex :: Pandoc,
nebelhornTemplateArticle :: String,
nebelhornTemplatePage :: String,
nebelhornTemplateIndex :: String
}
module File (load, save, copyFolders) where
import ClassyPrelude hiding ((</>))
import Path
import Path.IO
-- | Predicate that checks whether a file is a markdown file using the file extension.
isMarkdownFile :: Path b File -> Bool
isMarkdownFile path = ext == ".md" || ext == ".markdown"
where ext = fileExtension path
-- | Reads all markdown files from a folder recursively,
-- returning their contents and paths (relative to the folder path).
load :: MonadIO m => Path b Dir -> m [(Path Rel File, Text)]
load basePath = do
(_, filesAll) <- listDirRecurRel basePath
let files = filter isMarkdownFile filesAll
contents <- liftIO $ readFileUtf8 `mapM` (toFilePath . (basePath </>) <$> files)
return $ zip files contents
-- | Saves a list of files to the specified paths relative to a base path.
save :: (MonadIO m) => Path b Dir -> [(Path Rel File, Text)] -> m ()
save basePath = mapM_ $ \(path, output) -> do
let fileOutput = basePath </> path
ensureDir $ parent fileOutput
writeFileUtf8 (toFilePath fileOutput) output
-- | Copies folders verbatim according to the target folder.
copyFolders :: [Path Rel Dir] -> Path a Dir -> IO ()
copyFolders sources sink = forM_ sources $ \source -> copyDirRecur source (sink </> source)
module Load (load) where
import ClassyPrelude hiding ((</>))
import qualified Data.Map.Strict as Map
import Path
import Path.IO
import Text.Pandoc.Readers.Markdown
import Text.Pandoc.Definition
import Text.Pandoc.Class
import Text.Pandoc.Options
import Definition
import Config
import Util
-- | Reads in a Nebelhorn value using a config.
load :: (PandocMonad m, MonadIO m) => Config -> m Nebelhorn
load Config{..} = Nebelhorn
<$> return configFolderOutput
<*> return configFoldersToCopy
<*> return configNavbar
<*> (uncurry linkIntoMeta <$$> prependPath configFolderArticle <$$> readFolder configFolderArticle)
<*> (uncurry linkIntoMeta <$$> readFolder configFolderPage)
<*> return (Pandoc (Meta $ Map.singleton "link" $ MetaString "index.html") [])
<*> (unpack <$> readFileUtf8 (toFilePath configTemplateArticle))
<*> (unpack <$> readFileUtf8 (toFilePath configTemplatePage))
<*> (unpack <$> readFileUtf8 (toFilePath configTemplateIndex))
prependPath :: Path a Dir -> (Path Rel b, t) -> (Path a b, t)
prependPath basePath (path, x) = (basePath </> path, x)
-- | Puts a path into the meta values of a pandocument.
linkIntoMeta :: Path a File -> Pandoc -> Pandoc
linkIntoMeta link (Pandoc (Meta metaMap) bs)
= Pandoc (Meta $ Map.insert "link" (MetaString $ toFilePath link) metaMap) bs
-- | Reads all markdown files from a folder recursively,
-- returning their contents and paths (relative to the folder path).
readFolder :: (MonadIO m, PandocMonad m) => Path b Dir -> m [(Path Rel File, Pandoc)]
readFolder basePath = do
(_, filesAll) <- listDirRecurRel basePath
let files = filter isMarkdownFile filesAll
contents <- readFileUtf8 `mapM` (toFilePath . (basePath </>) <$> files)
docs <- readMarkdown opts `mapM` contents
files' <- liftIO $ setFileExtension ".html" `mapM` files
return $ zip files' docs
where opts = def {readerExtensions = pandocExtensions}
-- | Predicate that checks whether a file is a markdown file using the file extension.
isMarkdownFile :: Path b File -> Bool
isMarkdownFile path = ext == ".md" || ext == ".markdown"
where ext = fileExtension path
module Main where
import ClassyPrelude hiding ((</>))
import System.Process
import Text.Pandoc.Class
import Config
import Build
main :: IO ()
main = loadConfig >>= \case
Left err -> putStrLn $ tshow err
Right config -> runIO (build config) >>= \case
Left err -> putStrLn $ tshow err
Right () -> do
callCommand "sassc -m style/stylesheet.scss out/style/stylesheet.css"
putStrLn "Success!"
{-# LANGUAGE QuasiQuotes #-}
module Save where
import ClassyPrelude hiding ((</>))
import Path
import Path.IO
import Text.Pandoc.Writers.HTML
import Text.Pandoc.Class
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Definition
save :: (PandocMonad m, MonadIO m) => Nebelhorn -> m ()
save Nebelhorn{..} = do
writeDocument nebelhornTemplateArticle nebelhornFolderOutput `mapM_` nebelhornArticles
writeDocument nebelhornTemplatePage nebelhornFolderOutput `mapM_` nebelhornPages
writeDocument nebelhornTemplateIndex nebelhornFolderOutput nebelhornIndex
liftIO $ copyFolders nebelhornFoldersToCopy nebelhornFolderOutput
-- | Saves a list of files to the specified paths relative to a base path.
writeDocument :: (PandocMonad m, MonadIO m) => String -> Path b Dir -> Pandoc -> m ()
writeDocument template basePath doc = do
let fileOutput = basePath </> fromMaybe [relfile|unknown|] (getLink doc)
ensureDir $ parent fileOutput
output <- writeHtml5String writerOptions doc
writeFileUtf8 (toFilePath fileOutput) output
where writerOptions = def{writerExtensions = pandocExtensions, writerTemplate = Just $ unpack template}
-- | Copies folders verbatim according to the target folder.
copyFolders :: [Path Rel Dir] -> Path a Dir -> IO ()
copyFolders sources sink = forM_ sources $ \source -> copyDirRecur source (sink </> source)
getLink :: Pandoc -> Maybe (Path Rel File)
getLink (Pandoc meta _) = lookupMeta "link" meta >>= \(MetaString link) -> parseRelFile link
-- | This module contains utility functions.
module Util where
import ClassyPrelude
import Text.Pandoc.Definition
import qualified Data.Map.Strict as Map
{- |
A handy nested map function. Works just like the normal inline map '<$>', but nested.
Example: @(+1) <$$> [[1, 2], [3, 4]]@ evaluates to @[[2, 3], [4, 5]]@.
-}
infixr 5 <$$>
(<$$>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)
(<$$>) = fmap . fmap
-- | The monadic equivalent of the nested map '<$$>'.
mapMT :: (Traversable t1, Traversable t2, Monad m) => (a -> m b) -> t1 (t2 a) -> m (t1 (t2 b))
mapMT = mapM . mapM
-- | Adds a key-metavalue pair to a pandocument. Already known keys are overwritten.
addMeta :: String -> MetaValue -> Pandoc -> Pandoc
addMeta key value (Pandoc (Meta metaMap) bs)
= Pandoc (Meta $ Map.insert key value metaMap) bs
import ClassyPrelude
import Build
main :: IO ()
main = build
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment