Start adding a Markdown data type common to Articles and Pages, refactor here and there, will need some more renaming / refactoring in DOM module

hablo.cabal

@@ -45,6 +45,7 @@ executable hablo
                      , HTML
                      , JS
                      , JSON
+                     , Markdown
                      , Page
                      , Paths_hablo
                      , Pretty

src/Article.hs

@@ -1,76 +1,24 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE FlexibleContexts #-}
 module Article (
       Article(..)
     , at
-    , getKey
     , preview
   ) where
 
 import Control.Applicative ((<|>))
-import Data.Map (Map)
-import qualified Data.Map as Map (fromList, alter)
+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 System.FilePath (dropExtension, takeFileName)
+import Markdown (Markdown(..), Metadata)
+import qualified Markdown (at)
 import System.Posix.Files (getFileStatus, modificationTime)
-import Text.ParserCombinators.Parsec (
-      ParseError
-    , Parser
-    , (<?>)
-    , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf
-    , oneOf, option, parse, skipMany, sourceLine, string, try
-  )
+import Text.ParserCombinators.Parsec (ParseError)
 
-type Metadata = Map String String
-
-data Article = Article {
-      key :: String
-    , title :: String
-    , metadata :: Metadata
-    , bodyOffset :: Int
-    , body :: [String]
+newtype Article = Article {
+    getMarkdown :: Markdown
   }
 
-type ProtoArticle = (String, Metadata, Int, [String])
-
-articleP :: Parser ProtoArticle
-articleP =
-  skipMany eol *> headerP <* skipMany eol <*> lineOffset <*> bodyP
-  where
-    headerP =
-        try ((,,,) <$> titleP <* many eol <*> metadataP)
-      <|> flip (,,,) <$> metadataP  <* many eol<*> titleP
-    lineOffset = pred . sourceLine <$> getPosition
-    bodyP = lines <$> many anyChar <* eof
-
-metadataP :: Parser Metadata
-metadataP = Map.fromList <$> option [] (
-    metaSectionSeparator *> many eol *>
-    (try keyVal) `endBy` (many1 eol)
-    <* metaSectionSeparator
-  ) <?> "metadata section"
-  where
-    metaSectionSeparator = count 3 (oneOf "~-") *> eol
-    spaces = skipMany $ char ' '
-    keyVal = (,) <$> (no ": \r\n" <* spaces <* char ':' <* spaces) <*> no "\r\n"
-
-titleP :: Parser String
-titleP = try (singleLine <|> underlined)
-  where
-    singleLine = char '#' *> char ' ' *> no "\r\n" <* eol
-    underlined =
-      no "\r\n" <* eol
-      >>= \titleLine -> count (length titleLine) (oneOf "#=") *> eol *> return titleLine
-      <?> "'#' or '=' to underline the title"
-
-eol :: Parser String
-eol = try (string "\r\n") <|> string "\r" <|> string "\n" <?> "newline"
-
-no :: String -> Parser String
-no = many1 . noneOf
-
 setDate :: String -> CTime -> Metadata -> Metadata
 setDate tzOffset defaultDate = Map.alter timeStamp "date"
   where
@@ -82,27 +30,16 @@ setDate tzOffset defaultDate = Map.alter timeStamp "date"
       let parsedTimes = parseTimeM True defaultTimeLocale <$> formats <*> dates in
       foldr (<|>) (timeStamp Nothing) (fmap epoch <$> parsedTimes)
 
-makeArticle :: FilePath -> (Metadata -> Metadata) -> ProtoArticle -> (String, Article)
-makeArticle filePath metaFilter (title, metadata, bodyOffset, body) = (
-      getKey filePath
-    , Article {
-          key = getKey filePath
-        , title
-        , metadata = metaFilter metadata
-        , bodyOffset
-        , body
-      }
-  )
+makeArticle :: (Metadata -> Metadata) -> Markdown -> (String, Article)
+makeArticle metaFilter markdown@(Markdown {key, metadata}) =
+  (key, Article $ markdown {metadata = metaFilter metadata})
 
 at :: FilePath -> IO (Either ParseError (String, Article))
 at filePath = do
   tzOffset <- timeZoneOffsetString <$> getCurrentTimeZone
   fileDate <- modificationTime <$> getFileStatus filePath
-  let build = makeArticle filePath (setDate tzOffset fileDate)
-  fmap build . parse articleP filePath <$> readFile filePath
+  fmap (makeArticle (setDate tzOffset fileDate)) <$> Markdown.at filePath
 
-getKey :: FilePath -> String
-getKey = dropExtension . takeFileName
-
-preview :: Int -> Article -> Article
-preview linesCount article = article {body = take linesCount $ body article}
+preview :: Int -> Markdown -> Markdown
+preview linesCount markdown@(Markdown {body}) =
+  markdown {body = take linesCount $ body}

src/Blog.hs

@@ -15,7 +15,7 @@ module Blog (
 import Arguments (Arguments)
 import qualified Arguments (name, sourceDir)
 import Article (Article)
-import qualified Article (at, getKey)
+import qualified Article (at)
 import Blog.Path (Path(..))
 import qualified Blog.Path as Path (build)
 import Blog.Template (Environment, Templates, render)
@@ -36,6 +36,7 @@ import qualified Data.Set as Set (empty, null, singleton, union)
 import Data.Text (Text)
 import Files (File(..), absolute)
 import qualified Files (find)
+import Markdown (getKey)
 import Page (Page)
 import qualified Page (at)
 import Prelude hiding (lookup)
@@ -88,7 +89,7 @@ tagged collection path = do
   keys <- forM links $ \link -> do
     fileExists <- doesFileExist link
     return $ if fileExists
-      then let articleKey = Article.getKey link in
+      then let articleKey = getKey link in
         maybe Set.empty (\_ -> Set.singleton articleKey) (lookup articleKey collection)
       else Set.empty
   return (takeFileName path, foldl Set.union Set.empty keys)

src/Collection.hs

@@ -6,7 +6,7 @@ module Collection (
     , title
   ) where
 
-import Article(Article(metadata))
+import Article(Article(..))
 import Blog (Blog(..), Path(..))
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (MonadReader(..), ReaderT, asks)
@@ -15,6 +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 Pretty ((.$))
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath ((</>))
@@ -34,7 +35,7 @@ build featured tag = do
       featured = sortByDate featured, basePath, tag
     }
   where
-    sortByDate = sortOn (Down . (! "date") . metadata)
+    sortByDate = sortOn (Down . (! "date") . metadata . getMarkdown)
 
 getAll :: ReaderT Blog IO [Collection]
 getAll = do

src/DOM/Card.hs

@@ -2,12 +2,11 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 module DOM.Card (
-      Card(..)
-    , HasCard(..)
+      HasCard(..)
     , make
   ) where
 
-import qualified Article (Article(..))
+import Article (Article(..))
 import ArticlesList (ArticlesList(..))
 import qualified ArticlesList (description)
 import Blog (Blog(..), Renderer, Skin(..))
@@ -19,18 +18,16 @@ import qualified Data.Map as Map (lookup)
 import Data.Text (Text, pack)
 import Lucid (HtmlT, content_, meta_)
 import Lucid.Base (makeAttribute)
+import qualified Markdown (Markdown(..))
+import Page (Page(..))
 import Pretty ((.$))
 
-data Card = Card {
-      cardType :: Text
-    , description :: Text
-    , image :: Maybe String
-    , title :: String
-    , urlPath :: String
-  }
-
 class HasCard a where
-  getCard :: Renderer m => a -> m Card
+  cardType :: Renderer m => a -> m Text
+  description :: Renderer m => a -> m Text
+  image :: Renderer m => a -> m (Maybe String)
+  title :: Renderer m => a -> m String
+  urlPath :: Renderer m => a -> m String
 
 og :: Applicative m => Text -> Text -> HtmlT m ()
 og attribute value =
@@ -41,30 +38,49 @@ og attribute value =
 
 make :: (HasCard a, Renderer m) => a -> String -> HtmlT m ()
 make element siteURL = do
-  Card {cardType, description, image, title, urlPath} <- getCard element
-  og "url" . pack $ siteURL ++ urlPath
-  og "type" cardType
-  og "title" $ pack title
-  og "description" description
-  maybeImage =<< ((image <|>) <$> (asks $skin.$cardImage))
+  og "url" . sitePrefix =<< urlPath element
+  og "type" =<< cardType element
+  og "title" . pack =<< title element
+  og "description" =<< description element
+  maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage))
   og "site_name" =<< (asks $name.$pack)
   where
-    maybeImage = maybe (return ()) (og "image" . pack . (siteURL++))
+    maybeImage = maybe (return ()) (og "image" . sitePrefix)
+    sitePrefix = pack . (siteURL ++)
 
-instance HasCard Article.Article where
-  getCard (Article.Article {Article.title, Article.metadata}) = do
-    description <- pack <$> getDescription (Map.lookup "summary" metadata)
-    return $ Card {
-          cardType = "article"
-        , description
-        , image = (Map.lookup "featuredImage" metadata)
-        , DOM.Card.title
-        , urlPath = "/articles/" ++ title ++ ".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 = fmap (\t -> "/articles/" ++ t ++ ".html") . title
+
+instance HasCard Page where
+  cardType _ = return "website"
+  description page@(Page (Markdown.Markdown {Markdown.metadata})) =
+    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 = fmap (\t -> "/pages/" ++ t ++ ".html") . title
 
 instance HasCard ArticlesList where
+  cardType _ = return "website"
+  description = ArticlesList.description
+  image _ = return Nothing
+  title (ArticlesList {collection}) = Collection.title collection
+  urlPath al@(ArticlesList {collection}) =
+    return $ maybe "" ('/':) (tag collection) ++ file
+    where
+      file = '/' : (if full al then "all" else "index") ++ ".html"
+
+{-
   getCard al@(ArticlesList {collection}) = do
     cardTitle <- Collection.title collection
     description <- ArticlesList.description al
@@ -77,3 +93,4 @@ instance HasCard ArticlesList where
       }
     where
       file = '/' : (if full al then "all" else "index") ++ ".html"
+-}

src/JS.hs

@@ -3,6 +3,8 @@ module JS (
     generate
   ) where
 
+import Data.Aeson (encode)
+
 import Blog (Blog(..), Path(..))
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (ReaderT, asks)
@@ -31,7 +33,7 @@ var (varName, content) = concat ["\t", pack varName, " : ", content]
 
 generateConfig :: FilePath -> ReaderT Blog IO ()
 generateConfig destinationDir = do
-  blogJSON <- exportBlog
+  blogJSON <- asks (encode . exportBlog)
   remarkablePath <- asks $path.$remarkableConfig
   liftIO $ do
     remarkableJSON <- maybe (return "{html: true}") readFile remarkablePath

src/JSON.hs

@@ -4,58 +4,65 @@ module JSON (
     exportBlog
   ) where
 
-import Article (Article)
 import qualified Article (Article(..))
 import Blog (Blog, Path, Skin, URL, Wording)
 import qualified Blog (Blog(..))
-import Control.Monad.Reader (ReaderT, ask)
-import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode)
-import Data.ByteString.Lazy (ByteString)
+import Data.Aeson (Options(..), ToJSON(..), genericToEncoding, defaultOptions)
 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 qualified Markdown (Markdown(..))
+import qualified Page (Page(..))
 
-data ArticleExport = ArticleExport {
+data MarkdownExport = MarkdownExport {
       title :: String
-    , bodyOffset :: Int
     , metadata :: Map String String
-    , tagged :: [String]
+    , bodyOffset :: Int
+    , tagged :: Maybe [String]
   } deriving (Generic)
 
-instance ToJSON ArticleExport where
-  toEncoding = genericToEncoding defaultOptions
+instance ToJSON MarkdownExport where
+  toEncoding = genericToEncoding (defaultOptions {omitNothingFields = True})
 
-data BlogDB = BlogDB {
-      articles :: Map String ArticleExport
+exportMarkdown :: Maybe [String] -> Markdown -> MarkdownExport
+--exportMarkdown :: Blog -> String -> Markdown -> MarkdownExport
+exportMarkdown tagged markdown = MarkdownExport {
+--exportMarkdown blog key article = MarkdownExport {
+      title = Markdown.title markdown
+    , metadata = Markdown.metadata markdown
+    , bodyOffset = Markdown.bodyOffset markdown
+    , tagged
+    --, tagged = Map.keys . Map.filter (Set.member key) $ Blog.tags blog
+  }
+
+data BlogExport = BlogExport {
+      articles :: Map String MarkdownExport
     , hasRSS :: Bool
     , path :: Path
+    , pages :: Map String MarkdownExport
     , skin :: Skin
     , tags :: Map String [String]
     , urls :: URL
     , wording :: Wording
   } deriving (Generic)
 
-instance ToJSON BlogDB where
+instance ToJSON BlogExport where
   toEncoding = genericToEncoding defaultOptions
 
-exportArticle :: Blog -> String -> Article -> ArticleExport
-exportArticle blog key article = ArticleExport {
-      title = Article.title article
-    , bodyOffset = Article.bodyOffset article
-    , metadata = Article.metadata article
-    , tagged = Map.keys . Map.filter (Set.member key) $ Blog.tags blog
-  }
-
-exportBlog :: ReaderT Blog IO ByteString
-exportBlog = do
-  blog <- ask
-  return . encode $ BlogDB {
-        articles = mapWithKey (exportArticle blog) $ Blog.articles blog
+exportBlog :: Blog -> BlogExport
+exportBlog blog = BlogExport {
+      articles = getArticles $ Article.getMarkdown <$> Blog.articles blog
     , hasRSS = Blog.hasRSS blog
+    , pages = getPages $ Page.getMarkdown <$> Blog.pages blog
     , path = Blog.path blog
     , skin = Blog.skin blog
     , tags = Set.elems <$> Blog.tags blog
     , urls = Blog.urls blog
     , wording = Blog.wording blog
   }
+  where
+    tag key = Just . Map.keys . Map.filter (Set.member key) $ Blog.tags blog
+    getArticles = mapWithKey (exportMarkdown . tag)
+    getPages = mapWithKey (\_-> exportMarkdown Nothing)

src/Markdown.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Markdown (
+      Markdown(..)
+    , Metadata
+    , at
+    , getKey
+    , parser
+  ) where
+
+import Control.Applicative ((<|>))
+import Data.Map (Map)
+import qualified Data.Map as Map (fromList)
+import System.FilePath (dropExtension, takeFileName)
+import Text.ParserCombinators.Parsec (
+     ParseError, Parser
+    , (<?>)
+    , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf
+    , oneOf, option, parse, skipMany, sourceLine, string, try
+  )
+
+type Metadata = Map String String
+data Markdown = Markdown {
+      key :: String
+    , title :: String
+    , metadata :: Metadata
+    , bodyOffset :: Int
+    , body :: [String]
+  }
+
+parser :: String -> Parser Markdown
+parser key = do
+  (title, metadata) <- skipMany eol *> (headerP <|> reverseHeaderP)
+  bodyOffset <- skipMany eol *> (pred . sourceLine <$> getPosition)
+  body <- lines <$> many anyChar <* eof
+  return $ Markdown {key, title, metadata, bodyOffset, body}
+  where
+    headerP = (,) <$> titleP <* many eol <*> metadataP
+    reverseHeaderP = flip (,) <$> metadataP  <* many eol<*> titleP
+
+metadataP :: Parser Metadata
+metadataP = Map.fromList <$> option [] (
+    metaSectionSeparator *> many eol *>
+    (try keyVal) `endBy` (many1 eol)
+    <* metaSectionSeparator
+  ) <?> "metadata section"
+  where
+    metaSectionSeparator = count 3 (oneOf "~-") *> eol
+    spaces = skipMany $ char ' '
+    keyVal = (,) <$> (no ": \r\n" <* spaces <* char ':' <* spaces) <*> no "\r\n"
+
+titleP :: Parser String
+titleP = try (singleLine <|> underlined)
+  where
+    singleLine = char '#' *> char ' ' *> no "\r\n" <* eol
+    underlined =
+      no "\r\n" <* eol
+      >>= \titleLine -> count (length titleLine) (oneOf "#=") *> eol *> return titleLine
+      <?> "'#' or '=' to underline the title"
+
+eol :: Parser String
+eol = try (string "\r\n") <|> string "\r" <|> string "\n" <?> "newline"
+
+no :: String -> Parser String
+no = many1 . noneOf
+
+getKey :: FilePath -> String
+getKey = dropExtension . takeFileName
+
+at :: FilePath -> IO (Either ParseError Markdown)
+at filePath = parse (parser (getKey filePath)) filePath <$> readFile filePath

src/Page.hs

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