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

- containers  # For Map

- yaml

- process

- exceptions

default-extensions:

- NoImplicitPrelude

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

    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.

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

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)

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)