From 4368f305316550d4ee9c6b9312eea096aa3b78e9 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Fri, 22 Feb 2019 23:29:35 +0100 Subject: [PATCH] Refactor code to get rid of fake *Export types --- src/Blog/Path.hs | 13 ++++++++- src/Blog/Skin.hs | 12 +++++++- src/Blog/Wording.hs | 32 ++++++++++++-------- src/JSON.hs | 71 +++++++-------------------------------------- 4 files changed, 54 insertions(+), 74 deletions(-) diff --git a/src/Blog/Path.hs b/src/Blog/Path.hs index 362d61f..e3b3bff 100644 --- a/src/Blog/Path.hs +++ b/src/Blog/Path.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Blog.Path ( Path(..) , build @@ -6,7 +8,9 @@ module Blog.Path ( import Arguments (Arguments) import qualified Arguments as Arguments (Arguments(..)) +import Data.Aeson (ToJSON(..), (.=), pairs) import Files (File(..), absolute, filePath) +import GHC.Generics (Generic) data Path = Path { articlesPath :: FilePath @@ -14,7 +18,14 @@ data Path = Path { , pagesPath :: Maybe FilePath , remarkableConfig :: Maybe FilePath , root :: FilePath - } + } deriving Generic + +instance ToJSON Path where + toEncoding (Path {articlesPath, commentsAt, pagesPath}) = pairs ( + "articlesPath" .= articlesPath + <> "commentsAt" .= commentsAt + <> "pagesPath" .= pagesPath + ) build :: Arguments -> IO Path build arguments = do diff --git a/src/Blog/Skin.hs b/src/Blog/Skin.hs index a5cf2f5..79d3093 100644 --- a/src/Blog/Skin.hs +++ b/src/Blog/Skin.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Blog.Skin ( Skin(..) , build @@ -7,8 +9,10 @@ module Blog.Skin ( import Arguments (Arguments) import qualified Arguments (bannerPath, favicon, cardImage, headPath, previewArticlesCount, previewLinesCount) import Control.Monad (filterM) +import Data.Aeson (ToJSON(..), (.=), pairs) import Data.Maybe (listToMaybe) import Files (absoluteLink) +import GHC.Generics (Generic) import Prelude hiding (head) import System.Directory (doesFileExist) import System.FilePath ((), (<.>)) @@ -20,7 +24,13 @@ data Skin = Skin { , head :: Maybe String , previewArticlesCount :: Int , previewLinesCount :: Int - } + } deriving Generic + +instance ToJSON Skin where + toEncoding (Skin {previewArticlesCount, previewLinesCount}) = pairs ( + "previewArticlesCount" .= previewArticlesCount + <> "previewLinesCount" .= previewLinesCount + ) findImage :: String -> Maybe FilePath -> IO (Maybe FilePath) findImage _ (Just path) = return . Just $ absoluteLink path diff --git a/src/Blog/Wording.hs b/src/Blog/Wording.hs index c67be10..27d5314 100644 --- a/src/Blog/Wording.hs +++ b/src/Blog/Wording.hs @@ -7,12 +7,13 @@ module Blog.Wording ( import Arguments (Arguments(..)) import Control.Monad (foldM) +import Data.Aeson (ToJSON(..), (.=), object, pairs) import Data.List (intercalate) import Data.Map (Map, (!)) import qualified Data.Map as Map (empty, fromList, map, union) import Data.Text (Text) import qualified Data.Text as Text (pack, unpack) -import Data.Text.Template (Template, renderA, templateSafe) +import Data.Text.Template (Template, renderA, showTemplate, templateSafe) import Paths_hablo (getDataFileName) import Text.ParserCombinators.Parsec ( Parser @@ -32,18 +33,25 @@ data Wording = Wording { , tagsList :: Text } -keys :: [Parser String] -keys = try . string <$> [ - "allLink" - , "allPage" - , "allTaggedPage" - , "commentsSection" - , "latestLink" - , "latestPage" - , "latestTaggedPage" - , "tagsList" +keys :: [String] +keys = [ + "allLink", "allPage", "allTaggedPage", "commentsSection" + , "latestLink", "latestPage", "latestTaggedPage", "tagsList" ] +values :: [Wording -> Text] +values = [ + allLink, allPage, showTemplate . allTaggedPage, commentsSection + , latestLink, latestPage, showTemplate . latestTaggedPage, tagsList + ] + +texts :: Wording -> [Text] +texts wording = ($ wording) <$> values + +instance ToJSON Wording where + toJSON = object . zipWith (.=) (Text.pack <$> keys) . texts + toEncoding = pairs . foldl (<>) mempty . zipWith (.=) (Text.pack <$> keys) . texts + addWording :: Map String Text -> FilePath -> IO (Map String Text) addWording currentWording wordingFile = do parsed <- parse wordingP wordingFile <$> readFile wordingFile @@ -54,7 +62,7 @@ addWording currentWording wordingFile = do wordingP :: Parser (Map String Text) wordingP = Map.map Text.pack . Map.fromList <$> (many eol *> line `endBy` (many1 eol)) where - line = (,) <$> (choice keys <* equal) <*> many (noneOf "\r\n") + line = (,) <$> (choice (try . string <$> keys) <* equal) <*> many (noneOf "\r\n") equal = many (char ' ') *> char '=' *> many (char ' ') eol = try (string "\r\n") <|> string "\r" <|> string "\n" diff --git a/src/JSON.hs b/src/JSON.hs index 7cfcc33..3522cab 100644 --- a/src/JSON.hs +++ b/src/JSON.hs @@ -6,16 +6,14 @@ module JSON ( import Article (Article) import qualified Article (Article(..)) -import Blog (Blog) -import qualified Blog (Blog(..), Path(..), Skin(..), Wording(..)) +import Blog (Blog, Path, Skin, 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.Map (Map, mapWithKey) import qualified Data.Map as Map (filter, keys) import qualified Data.Set as Set (elems, member) -import Data.Text (Text) -import Data.Text.Template (showTemplate) import GHC.Generics data ArticleExport = ArticleExport { @@ -28,50 +26,19 @@ data ArticleExport = ArticleExport { instance ToJSON ArticleExport where toEncoding = genericToEncoding defaultOptions -data PathExport = PathExport { - articlesPath :: FilePath - , commentsAt :: Maybe String - , pagesPath :: Maybe FilePath - } deriving (Generic) - -instance ToJSON PathExport where - toEncoding = genericToEncoding defaultOptions - -data SkinExport = SkinExport { - previewArticlesCount :: Int - , previewLinesCount :: Int - } deriving (Generic) - -instance ToJSON SkinExport where - toEncoding = genericToEncoding defaultOptions - -data WordingExport = WordingExport { - allLink :: Text - , allPage :: Text - , allTaggedPage :: Text - , commentsSection :: Text - , latestLink :: Text - , latestPage :: Text - , latestTaggedPage :: Text - , tagsList :: Text - } deriving (Generic) - -instance ToJSON WordingExport where - toEncoding = genericToEncoding defaultOptions - data BlogDB = BlogDB { articles :: Map String ArticleExport - , path :: PathExport - , skin :: SkinExport + , path :: Path + , skin :: Skin , tags :: Map String [String] - , wording :: WordingExport + , wording :: Wording } deriving (Generic) instance ToJSON BlogDB where toEncoding = genericToEncoding defaultOptions -export :: Blog -> String -> Article -> ArticleExport -export blog key article = ArticleExport { +exportArticle :: Blog -> String -> Article -> ArticleExport +exportArticle blog key article = ArticleExport { title = Article.title article , bodyOffset = Article.bodyOffset article , metadata = Article.metadata article @@ -82,25 +49,9 @@ exportBlog :: ReaderT Blog IO ByteString exportBlog = do blog <- ask return . encode $ BlogDB { - articles = mapWithKey (export blog) $ Blog.articles blog - , path = PathExport { - articlesPath = Blog.articlesPath $ Blog.path blog - , commentsAt = Blog.commentsAt $ Blog.path blog - , pagesPath = Blog.pagesPath $ Blog.path blog - } - , skin = SkinExport { - previewArticlesCount = Blog.previewArticlesCount $ Blog.skin blog - , previewLinesCount = Blog.previewLinesCount $ Blog.skin blog - } + articles = mapWithKey (exportArticle blog) $ Blog.articles blog + , path = Blog.path blog + , skin = Blog.skin blog , tags = Set.elems <$> Blog.tags blog - , wording = WordingExport { - allLink = Blog.allLink $ Blog.wording blog - , allPage = Blog.allPage $ Blog.wording blog - , allTaggedPage = showTemplate . Blog.allTaggedPage $ Blog.wording blog - , commentsSection = Blog.commentsSection $ Blog.wording blog - , latestLink = Blog.latestLink $ Blog.wording blog - , latestPage = Blog.latestPage $ Blog.wording blog - , latestTaggedPage = showTemplate . Blog.latestTaggedPage $ Blog.wording blog - , tagsList = Blog.tagsList $ Blog.wording blog - } + , wording = Blog.wording blog }