A lot of refactoring

package.yaml

@@ -6,10 +6,10 @@ author: "Nicolas Lenz"
 maintainer: "nicolas@eisfunke.com"
 copyright: "2019 Nicolas Lenz"
 
-extra-source-files:
+extra-doc-files:
 - README.md
 
-synopsis: A static blog generator using Pandoc.
+synopsis: A static website generator using Pandoc.
 category: Web
 description: Please see the README at <https://git.eisfunke.com/software/nebelhorn#readme>
 
@@ -22,23 +22,20 @@ dependencies:
 - text
 - pandoc
 - pandoc-types
-- containers
+- containers  # For Map
 - yaml
-- aeson
-- aeson-casing
-- blaze-html
 - process
-- exceptions
 
 default-extensions:
 - NoImplicitPrelude
 - OverloadedStrings
 - LambdaCase
+- RecordWildCards
 
 executables:
   nebelhorn:
-    main:                Main.hs
-    source-dirs:         src
+    main: main.hs
+    source-dirs: src
     ghc-options:
     - -Wall
     - -Wno-name-shadowing

src/Build.hs

-{-# LANGUAGE LambdaCase, RecordWildCards, QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module Build (build) where
 
 import ClassyPrelude hiding ((</>))
 import Config
+import File
 import Path
-import Path.IO
 import System.Process
 import Text.Pandoc
 import qualified Data.Map as Map
 
-(<$$>) :: (Functor f1, Functor f2) => (a -> b) -> (f1 (f2 a)) -> (f1 (f2 b))
+{- |
+    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
 
--- | 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 $ mapM readFileUtf8 (toFilePath . (basePath </>) <$> files)
-    return $ zip files contents
-
--- | Saves a list of file contents with their relative paths to a folder, converting them to HTML5.
-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
-
-getNavbarMeta :: [Navitem] -> MetaValue
-getNavbarMeta navItems = MetaList $ map (\Navitem{..} -> MetaMap $ Map.fromList [("name", MetaString $ unpack navitemName), ("link", MetaString $ unpack navitemLink)]) navItems
-
-read :: (PandocMonad m) => Text -> m Pandoc
-read = readMarkdown readerOptions where
-    readerOptions = def {readerExtensions = pandocExtensions}
-
--- TODO: Deduplicate
-
-readPages :: (PandocMonad m, MonadIO m) => Meta -> [(Path Rel File, Text)] -> m [(Path Rel File, Pandoc)]
-readPages extraMeta inputs = do
-    outputs <- forM inputs $ \(path, content) -> do
-        contentR <- read content
-        return (path, contentR)
-    outputs <- forM outputs $ \(path, content) -> liftIO $ do
-        newPath <- setFileExtension ".html" path  -- TODO: This should really be done without IO...
-        return (newPath, content)
-    let outputs' = addMeta extraMeta <$$> outputs
-    return outputs'
-
-readArticles :: (PandocMonad m, MonadIO m) => Meta -> [(Path Rel File, Text)] -> m (Pandoc, [(Path Rel File, Pandoc)])
-readArticles extraMeta inputs = do
-    outputs <- forM inputs $ \(path, content) -> do
-        contentR <- read content
-        return (path, contentR)
-    outputs <- forM outputs $ \(path, content) -> liftIO $ do
-        newPath <- setFileExtension ".html" path  -- TODO: This should really be done without IO...
-        return (newPath, content)
-    let outputs' = addMeta extraMeta <$$> outputs
-    return (generateIndex extraMeta outputs', outputs')
+-- | 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
+
+-- | Generate the Pandoc MetaValue for a navbar from a list of NavItem from a Nebelhorn config.
+generateNavbarMeta :: [NavItem] -> MetaValue
+generateNavbarMeta navItems = MetaList $ map (\NavItem{..} -> MetaMap $ Map.fromList [("name", MetaString $ unpack navItemName), ("link", MetaString $ unpack navItemLink)]) navItems
 
+-- | 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 extraMeta (path, content) = do
+    contentR <- read' content
+    newPath <- liftIO $ setFileExtension ".html" path  -- TODO: This should really be done without IO...
+    return (newPath, addMeta extraMeta 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}
 
-buildPages :: (PandocMonad m, MonadIO m) => Text -> MetaValue -> [(Path Rel File, Text)] -> m [(Path Rel File, Text)]
-buildPages template navbar inputs = do
-    pagesInput <- readPages extraMeta inputs
-    f `mapM` pagesInput
+-- | 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)]
-        f (path, content) = do
-            contentW <- write template content
-            return (path, contentW)
-
-buildArticles :: (PandocMonad m, MonadIO m) => Text -> Text -> MetaValue -> [(Path Rel File, Text)] -> m (Text, [(Path Rel File, Text)])
-buildArticles templateArticle templateIndex navbar inputs = do
-    (indexInput, articlesInput) <- readArticles extraMeta inputs
-    articlesOutput <- f `mapM` articlesInput
+
+-- | 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 <- read extraMeta `mapM` inputs
+    let indexInput = generateIndex extraMeta articlesInput
+
+    articlesOutput <- write templateArticle `mapMT` articlesInput
     indexOutput <- write templateIndex indexInput
+
     return (indexOutput, articlesOutput)
+
     where
         extraMeta = Meta $ Map.fromList [("navbar", navbar)]
-        f (path, content) = do
-            contentW <- write templateArticle content
-            return (path, contentW)
 
+-- | Generate an index page from a list of Articles.
 generateIndex :: Meta -> [(Path Rel File, Pandoc)] -> Pandoc
-generateIndex extraMeta = generateIndex' . sortOn (Down . (\(_, Pandoc meta _) -> lookupMeta "date" meta)) where
-    generateIndex' :: [(Path Rel File, Pandoc)] -> Pandoc
+generateIndex extraMeta = generateIndex' . sort where
+    sort = sortOn (Down . (\(_, Pandoc meta _) -> lookupMeta "date" meta))
     generateIndex' articles = Pandoc metaOutput [] where
         metaOutput = extraMeta <> Meta (Map.fromList [("pagetitle", MetaString "Home"), ("articles", MetaList articlesOutput)])
         articlesOutput = (uncurry generateIndexMeta) <$> articles
 
--- | Generates the Pandoc MetaMap for a document for the index page. It contains the meta of the source, the link and the body
+-- | Generates the Pandoc MetaMap for a document for the index page. It contains the meta of the source, the link and the body.
 generateIndexMeta :: Path Rel File -> Pandoc -> MetaValue
 generateIndexMeta path (Pandoc (Meta metaMap) body) = MetaMap $ metaMap
     <> Map.fromList [("link", MetaString $ toFilePath path), ("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
-
-copyFolders :: Config -> IO ()
-copyFolders Config{..} = do
-    folders <- mapM parseRelDir configFoldersToCopy
-    forM_ folders $ \folder -> copyDirRecur folder ([reldir|out|] </> folder)
+addMeta (Meta metaMapExtra) (Pandoc (Meta metaMap) blocks)
+    = Pandoc (Meta $ metaMapExtra `Map.union` metaMap) blocks
 
+-- | Compile the stylesheet using sassc.
 compileStylesheet :: IO ()
 compileStylesheet = callCommand "sassc style/stylesheet.scss out/style/stylesheet.css"
 
 build :: IO ()
 build = loadConfig >>= \case
     Left ex -> fail $ "Error while reading config: " <> show ex
-    Right config@Config{..} -> do
-        copyFolders config
+    Right Config{..} -> do
+        copyFolders configFoldersToCopy configOutputFolder
         compileStylesheet
-        templateArticle <- readFileUtf8 configTemplateArticle
-        templatePage <- readFileUtf8 configTemplatePage
-        templateIndex <- readFileUtf8 configTemplateIndex
-        articlesInput <- (\(path, pandoc) -> ([reldir|article|] </> path, pandoc)) <$$> load [reldir|article|]
+
+        articlesInput <- prependPath <$$> load [reldir|article|]
         pagesInput <- load [reldir|page|]
-        articlesOutputE <- runIO (buildArticles templateArticle templateIndex (getNavbarMeta $ configNavbar) articlesInput)
-        pagesOutputE <- runIO (buildPages templatePage (getNavbarMeta $ configNavbar) pagesInput)
+
+        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 [reldir|out|] articlesOutput
-                save [reldir|out|] pagesOutput
-                writeFileUtf8 "out/index.html" indexOutput
+                save configOutputFolder articlesOutput
+                save configOutputFolder pagesOutput
+                save configOutputFolder [([relfile|index.html|], indexOutput)]
                 putStrLn "Success!"
+
+    where prependPath (path, pandoc) = ([reldir|article|] </> path, pandoc)

src/Config.hs

-{-# LANGUAGE DeriveGeneric, RecordWildCards #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module Config where
 
 import ClassyPrelude
 import Data.Yaml
-import Data.Aeson (genericParseJSON)
-import Data.Aeson.Casing
+import Path
 
 data Config = Config {
-    configTemplateArticle :: FilePath,
-    configTemplatePage :: FilePath,
-    configTemplateIndex :: FilePath,
-    configFoldersToCopy :: [FilePath],
-    configNavbar :: [Navitem]
-} deriving (Show, Generic)
+    configOutputFolder :: Path Rel Dir,
+    configFoldersToCopy :: [Path Rel Dir],
+    configNavbar :: [NavItem]
+} deriving (Show)
 
-data Navitem = Navitem {
-    navitemName :: Text,
-    navitemLink :: Text
-} deriving (Show, Generic)
+data NavItem = NavItem {
+    navItemName :: Text,
+    navItemLink :: Text
+} deriving (Show)
 
 instance FromJSON Config where
-    parseJSON = genericParseJSON $ aesonPrefix camelCase
+    parseJSON = withObject "Config" $ \v -> Config
+        <$> v .:? "outputFolder" .!= [reldir|out|]
+        <*> v .:? "foldersToCopy" .!= []
+        <*> v .:? "navbar" .!= [NavItem "Home" "/index.html"]
 
-instance FromJSON Navitem where
-    parseJSON = genericParseJSON $ aesonPrefix camelCase
+instance FromJSON NavItem where
+    parseJSON = withObject "NavItem" $ \v -> NavItem
+        <$> v .: "name"
+        <*> v .: "link"
 
 loadConfig :: IO (Either ParseException Config)
 loadConfig = decodeFileEither "nebelhorn.yaml"

src/File.hs

+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)

src/Main.hs

-module Main where
-
-import ClassyPrelude
-import Build
-
-main :: IO ()
-main = build
-{-
-    \case
-    Right config -> do
-        dir <- getCurrentDirectory
-        runIO (liftIO (compileStylesheet config) >> processPages config dir >> processArticles config dir) >>= \case
-            Left err -> putStrLn $ "An error occured during processing:\n" <> tshow err
-            Right _ -> putStrLn "Successfully sounded through the fog."
-    Left exception -> putStrLn $ "The configuration file couldn't be read:\n" <> pack (prettyPrintParseException exception)-}

src/Style.hs

-{-# LANGUAGE RecordWildCards #-}
-
-module Style where
-
-import ClassyPrelude
-import Config

src/main.hs

+import ClassyPrelude
+import Build
+
+main :: IO ()
+main = build