Refactor code to get rid of fake *Export types

This commit is contained in:
Tissevert 2019-02-22 23:29:35 +01:00
parent cfa501e3c4
commit 4368f30531
4 changed files with 54 additions and 74 deletions

View File

@ -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

View File

@ -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

View File

@ -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"

View File

@ -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
}