From 937a6858e01069b5f686c60f6c6e625e2c605f46 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sat, 20 Jun 2020 16:23:33 +0200 Subject: [PATCH] Add a class type for Markdown and implement HTML rendering for Pages --- src/Article.hs | 8 ++++---- src/Collection.hs | 4 ++-- src/DOM.hs | 13 +++++++++---- src/DOM/Card.hs | 24 ++++++++++++++++-------- src/HTML.hs | 16 ++++++++-------- src/JSON.hs | 8 +++----- src/Markdown.hs | 4 ++++ src/Page.hs | 8 ++++---- 8 files changed, 50 insertions(+), 35 deletions(-) diff --git a/src/Article.hs b/src/Article.hs index dd2acfc..8dcd3ea 100644 --- a/src/Article.hs +++ b/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" diff --git a/src/Collection.hs b/src/Collection.hs index 360fde9..03f0047 100644 --- a/src/Collection.hs +++ b/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 (()) diff --git a/src/DOM.hs b/src/DOM.hs index 8351f59..b38d31b 100644 --- a/src/DOM.hs +++ b/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 diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs index 0c9033b..08b1a46 100644 --- a/src/DOM/Card.hs +++ b/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" diff --git a/src/HTML.hs b/src/HTML.hs index 41d81ca..8b684ca 100644 --- a/src/HTML.hs +++ b/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 diff --git a/src/JSON.hs b/src/JSON.hs index 6902d3e..34404de 100644 --- a/src/JSON.hs +++ b/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 diff --git a/src/Markdown.hs b/src/Markdown.hs index 9f209ff..dc2c720 100644 --- a/src/Markdown.hs +++ b/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) diff --git a/src/Page.hs b/src/Page.hs index 1bd5d5f..2e638b9 100644 --- a/src/Page.hs +++ b/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