Add a class type for Markdown and implement HTML rendering for Pages

src/Article.hs

@@ -10,14 +10,14 @@ import qualified Data.Map as Map (alter)
 import Data.Time (defaultTimeLocale, getCurrentTimeZone, parseTimeM, timeZoneOffsetString)
 import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
 import Foreign.C.Types (CTime)
-import Markdown (Markdown(..), Metadata)
+import Markdown (Markdown(..), MarkdownContent(..), Metadata)
 import qualified Markdown (at)
 import System.Posix.Files (getFileStatus, modificationTime)
 import Text.ParserCombinators.Parsec (ParseError)
 
-newtype Article = Article {
-    getMarkdown :: Markdown
-  }
+newtype Article = Article Markdown
+instance MarkdownContent Article where
+  getMarkdown (Article markdown) = markdown
 
 setDate :: String -> CTime -> Metadata -> Metadata
 setDate tzOffset defaultDate = Map.alter timeStamp "date"

src/Collection.hs

@@ -6,7 +6,7 @@ module Collection (
     , title
   ) where
 
-import Article(Article(..))
+import Article(Article)
 import Blog (Blog(..), Path(..))
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (MonadReader(..), ReaderT, asks)
@@ -15,7 +15,7 @@ import Data.Map ((!))
 import qualified Data.Map as Map (elems, filterWithKey, toList)
 import Data.Ord (Down(..))
 import qualified Data.Set as Set (member)
-import Markdown (Markdown(metadata))
+import Markdown (Markdown(metadata), MarkdownContent(..))
 import Pretty ((.$))
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath ((</>))

src/DOM.hs

@@ -1,10 +1,11 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 module DOM (
-    htmlDocument
+      HasContent(..)
+    , htmlDocument
   ) where
 
-import Article (Article(..))
+import Article (Article)
 import qualified Article (preview)
 import ArticlesList (
     ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
@@ -21,7 +22,8 @@ import Lucid (
     , head_, header_, href_, li_, link_, id_, meta_, pre_, rel_, script_, src_
     , title_, toHtml, toHtmlRaw, type_, ul_
   )
-import Markdown (Markdown(..))
+import Markdown (Markdown(..), MarkdownContent(..))
+import Page (Page)
 import Prelude hiding (head, lookup)
 import Pretty ((.$))
 import System.FilePath.Posix ((<.>))
@@ -32,7 +34,10 @@ class HasCard a => HasContent a where
   content :: a -> HtmlGenerator ()
 
 instance HasContent Article where
-  content = markdown True . Article.getMarkdown
+  content = markdown True . getMarkdown
+
+instance HasContent Page where
+  content = markdown True . getMarkdown
 
 instance HasContent ArticlesList where
   content al@(ArticlesList {full}) = do

src/DOM/Card.hs

@@ -18,6 +18,7 @@ import qualified Data.Map as Map (lookup)
 import Data.Text (Text, pack)
 import Lucid (HtmlT, content_, meta_)
 import Lucid.Base (makeAttribute)
+import Markdown (MarkdownContent(..))
 import qualified Markdown (Markdown(..))
 import Page (Page(..))
 import Pretty ((.$))
@@ -49,16 +50,24 @@ make element siteURL = do
     maybeImage = maybe (return ()) (og "image" . sitePrefix)
     sitePrefix = pack . (siteURL </>)
 
+mDImage :: (Renderer m, MarkdownContent a ) => a -> m (Maybe String)
+mDImage = return . Map.lookup "featuredImage" . Markdown.metadata . getMarkdown
+
+mDTitle :: (Renderer m, MarkdownContent a) => a -> m String
+mDTitle = return . Markdown.title . getMarkdown
+
+mDUrlPath :: (Renderer m, MarkdownContent a) => a -> m String
+mDUrlPath a = return $ Markdown.path (getMarkdown a) <.> "html"
+
 instance HasCard Article where
   cardType _ = return "article"
   description (Article (Markdown.Markdown {Markdown.metadata})) =
     fmap pack . getDescription $ Map.lookup "summary" metadata
     where
       getDescription = maybe (asks $name.$("A new article on " <>)) return
-  image (Article (Markdown.Markdown {Markdown.metadata})) =
-    return $ Map.lookup "featuredImage" metadata
-  title = return . Markdown.title . Article.getMarkdown
-  urlPath (Article markdown) = return $ Markdown.path markdown <.> "html"
+  image = mDImage
+  title = mDTitle
+  urlPath = mDUrlPath
 
 instance HasCard Page where
   cardType _ = return "website"
@@ -66,10 +75,9 @@ instance HasCard Page where
     fmap pack . getDescription $ Map.lookup "summary" metadata
     where
       getDescription = maybe (title page) return
-  image (Page (Markdown.Markdown {Markdown.metadata})) =
-    return $ Map.lookup "featuredImage" metadata
-  title = return . Markdown.title . Page.getMarkdown
-  urlPath (Page markdown) = return $ Markdown.path markdown <.> "html"
+  image = mDImage
+  title = mDTitle
+  urlPath = mDUrlPath
 
 instance HasCard ArticlesList where
   cardType _ = return "website"

src/HTML.hs

@@ -4,7 +4,6 @@ module HTML (
     generate
   ) where
 
-import Article(Article(..))
 import ArticlesList (ArticlesList(..))
 import Blog (Blog(..), Path(..))
 import Collection (Collection(..))
@@ -13,9 +12,9 @@ import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (ReaderT, asks)
 import qualified Data.Map as Map (elems)
 import qualified Data.Text.Lazy.IO as TextIO (writeFile)
-import DOM (htmlDocument)
+import DOM (HasContent, htmlDocument)
 import Lucid (renderTextT)
-import Markdown (Markdown(..))
+import Markdown (Markdown(..), MarkdownContent(..))
 import Pretty ((.$))
 import System.FilePath.Posix ((</>), (<.>))
 
@@ -27,11 +26,11 @@ articlesLists collection@(Collection {basePath}) = [
     file bool = if bool then "all" else "index"
     path bool = basePath </> file bool <.> "html"
 
-generateArticles :: [Article] -> ReaderT Blog IO ()
-generateArticles = mapM_ $ \article -> do
-  let relativePath = Markdown.path (Article.getMarkdown article) <.> "html"
+generateMarkdown :: (HasContent a, MarkdownContent a) => [a] -> ReaderT Blog IO ()
+generateMarkdown = mapM_ $ \content -> do
+  let relativePath = Markdown.path (getMarkdown content) <.> "html"
   filePath <- (</> relativePath) <$> (asks $Blog.path.$root)
-  (renderTextT $ htmlDocument article) >>= liftIO . TextIO.writeFile filePath
+  (renderTextT $ htmlDocument content) >>= liftIO . TextIO.writeFile filePath
 
 generateCollection :: Collection -> ReaderT Blog IO ()
 generateCollection (Collection {featured = []}) = return ()
@@ -42,5 +41,6 @@ generateCollection collection =
 
 generate :: ReaderT Blog IO ()
 generate = do
-  asks articles >>= generateArticles . Map.elems
+  asks articles >>= generateMarkdown . Map.elems
   Collection.getAll >>= mapM_ generateCollection
+  asks pages >>= generateMarkdown . Map.elems

src/JSON.hs

@@ -4,7 +4,6 @@ module JSON (
     exportBlog
   ) where
 
-import qualified Article (Article(..))
 import Blog (Blog, Path, Skin, URL, Wording)
 import qualified Blog (Blog(..))
 import Data.Aeson (Options(..), ToJSON(..), genericToEncoding, defaultOptions)
@@ -12,9 +11,8 @@ import Data.Map (Map, mapWithKey)
 import qualified Data.Map as Map (filter, keys)
 import qualified Data.Set as Set (elems, member)
 import GHC.Generics
-import Markdown (Markdown)
+import Markdown (Markdown, MarkdownContent(..))
 import qualified Markdown (Markdown(..))
-import qualified Page (Page(..))
 
 data MarkdownExport = MarkdownExport {
       title :: String
@@ -50,9 +48,9 @@ instance ToJSON BlogExport where
 
 exportBlog :: Blog -> BlogExport
 exportBlog blog = BlogExport {
-      articles = getArticles $ Article.getMarkdown <$> Blog.articles blog
+      articles = getArticles $ getMarkdown <$> Blog.articles blog
     , hasRSS = Blog.hasRSS blog
-    , pages = getPages $ Page.getMarkdown <$> Blog.pages blog
+    , pages = getPages $ getMarkdown <$> Blog.pages blog
     , path = Blog.path blog
     , skin = Blog.skin blog
     , tags = Set.elems <$> Blog.tags blog

src/Markdown.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Markdown (
       Markdown(..)
+    , MarkdownContent(..)
     , Metadata
     , at
     , getKey
@@ -27,6 +28,9 @@ data Markdown = Markdown {
     , body :: [String]
   }
 
+class MarkdownContent a where
+  getMarkdown :: a -> Markdown
+
 parser :: Parser Markdown
 parser = do
   (title, metadata) <- skipMany eol *> (headerP <|> reverseHeaderP)

src/Page.hs

@@ -3,13 +3,13 @@ module Page (
     , at
   ) where
 
-import Markdown (Markdown(..))
+import Markdown (Markdown(..), MarkdownContent(..))
 import qualified Markdown as Markdown (at)
 import Text.ParserCombinators.Parsec (ParseError)
 
-newtype Page = Page {
-    getMarkdown :: Markdown
-  }
+newtype Page = Page Markdown
+instance MarkdownContent Page where
+  getMarkdown (Page markdown) = markdown
 
 at :: FilePath -> IO (Either ParseError (String, Page))
 at filePath = fmap makePage <$> Markdown.at filePath