Get rid of useless Blog.get that was actually a re-implementation of MonadReader's 'asks'
This commit is contained in:
parent
e180fef293
commit
58d2f3c1c2
4 changed files with 16 additions and 22 deletions
|
@ -9,7 +9,6 @@ module Blog (
|
||||||
, URL(..)
|
, URL(..)
|
||||||
, Wording
|
, Wording
|
||||||
, build
|
, build
|
||||||
, get
|
|
||||||
, template
|
, template
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
@ -61,9 +60,6 @@ type Renderer m = (MonadIO m, MonadReader Blog m)
|
||||||
template :: Renderer m => String -> Environment -> m Text
|
template :: Renderer m => String -> Environment -> m Text
|
||||||
template key environment = asks templates >>= render key environment
|
template key environment = asks templates >>= render key environment
|
||||||
|
|
||||||
get :: MonadReader Blog m => (Blog -> a) -> m a
|
|
||||||
get = asks
|
|
||||||
|
|
||||||
keepOrWarn :: Map String Article -> Either ParseError (String, Article) -> IO (Map String Article)
|
keepOrWarn :: Map String Article -> Either ParseError (String, Article) -> IO (Map String Article)
|
||||||
keepOrWarn accumulator (Left parseErrors) =
|
keepOrWarn accumulator (Left parseErrors) =
|
||||||
forM [show parseErrors, "=> Ignoring this article"] putStrLn
|
forM [show parseErrors, "=> Ignoring this article"] putStrLn
|
||||||
|
|
19
src/DOM.hs
19
src/DOM.hs
|
@ -10,7 +10,6 @@ import ArticlesList (
|
||||||
ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
|
ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
|
||||||
)
|
)
|
||||||
import Blog (Blog(..), Path(..), Skin(..), URL(..), template)
|
import Blog (Blog(..), Path(..), Skin(..), URL(..), template)
|
||||||
import qualified Blog (get)
|
|
||||||
import Control.Monad.Reader (ReaderT, asks)
|
import Control.Monad.Reader (ReaderT, asks)
|
||||||
import qualified Data.Map as Map (keys)
|
import qualified Data.Map as Map (keys)
|
||||||
import Data.Text (pack, empty)
|
import Data.Text (pack, empty)
|
||||||
|
@ -36,7 +35,7 @@ instance Page Article where
|
||||||
|
|
||||||
instance Page ArticlesList where
|
instance Page ArticlesList where
|
||||||
content al@(ArticlesList {full}) = do
|
content al@(ArticlesList {full}) = do
|
||||||
preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
|
preview <- Article.preview <$> (asks $skin.$previewLinesCount)
|
||||||
h2_ . toHtml =<< description al
|
h2_ . toHtml =<< description al
|
||||||
ul_ $ do
|
ul_ $ do
|
||||||
asks hasRSS >>= rssLink
|
asks hasRSS >>= rssLink
|
||||||
|
@ -55,7 +54,7 @@ instance Page ArticlesList where
|
||||||
|
|
||||||
article :: Bool -> Article -> HtmlGenerator ()
|
article :: Bool -> Article -> HtmlGenerator ()
|
||||||
article raw (Article {key, body, Article.title}) = do
|
article raw (Article {key, body, Article.title}) = do
|
||||||
url <- absoluteLink . (</> key <.> extension) <$> (Blog.get $path.$articlesPath)
|
url <- absoluteLink . (</> key <.> extension) <$> (asks $path.$articlesPath)
|
||||||
article_ [id_ $ pack key] (do
|
article_ [id_ $ pack key] (do
|
||||||
header_ (do
|
header_ (do
|
||||||
a_ [href_ $ pack url] . h1_ $ toHtml title
|
a_ [href_ $ pack url] . h1_ $ toHtml title
|
||||||
|
@ -73,7 +72,7 @@ defaultBanner :: HtmlGenerator ()
|
||||||
defaultBanner = do
|
defaultBanner = do
|
||||||
div_ [id_ "header"] (
|
div_ [id_ "header"] (
|
||||||
a_ [href_ "/"] (
|
a_ [href_ "/"] (
|
||||||
h1_ . toHtml =<< Blog.get name
|
h1_ . toHtml =<< asks name
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
|
@ -88,19 +87,19 @@ page aPage =
|
||||||
doctypehtml_ (do
|
doctypehtml_ (do
|
||||||
head_ (do
|
head_ (do
|
||||||
meta_ [charset_ "utf-8"]
|
meta_ [charset_ "utf-8"]
|
||||||
title_ . toHtml =<< Blog.get name
|
title_ . toHtml =<< asks name
|
||||||
script_ [src_ "/js/unit.js"] empty
|
script_ [src_ "/js/unit.js"] empty
|
||||||
script_ [src_ "/js/remarkable.min.js"] empty
|
script_ [src_ "/js/remarkable.min.js"] empty
|
||||||
script_ [src_ "/js/hablo.js"] empty
|
script_ [src_ "/js/hablo.js"] empty
|
||||||
optional faviconLink =<< (Blog.get $skin.$favicon)
|
optional faviconLink =<< (asks $skin.$favicon)
|
||||||
optional (Card.make aPage) =<< (Blog.get $urls.$cards)
|
optional (Card.make aPage) =<< (asks $urls.$cards)
|
||||||
(Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
|
(asks $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
|
||||||
)
|
)
|
||||||
body_ (do
|
body_ (do
|
||||||
maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
|
maybe defaultBanner toHtmlRaw =<< (asks $skin.$banner)
|
||||||
div_ [id_ "navigator"] (do
|
div_ [id_ "navigator"] (do
|
||||||
h2_ . toHtml =<< template "tagsList" []
|
h2_ . toHtml =<< template "tagsList" []
|
||||||
ul_ . mapM_ tag . Map.keys =<< Blog.get tags
|
ul_ . mapM_ tag . Map.keys =<< asks tags
|
||||||
)
|
)
|
||||||
div_ [id_ "contents"] $ content aPage
|
div_ [id_ "contents"] $ content aPage
|
||||||
)
|
)
|
||||||
|
|
|
@ -11,10 +11,10 @@ import qualified Article (Article(..))
|
||||||
import ArticlesList (ArticlesList(..))
|
import ArticlesList (ArticlesList(..))
|
||||||
import qualified ArticlesList (description)
|
import qualified ArticlesList (description)
|
||||||
import Blog (Blog(..), Renderer, Skin(..))
|
import Blog (Blog(..), Renderer, Skin(..))
|
||||||
import qualified Blog (get)
|
|
||||||
import Collection (Collection(..))
|
import Collection (Collection(..))
|
||||||
import qualified Collection (title)
|
import qualified Collection (title)
|
||||||
import Control.Applicative ((<|>))
|
import Control.Applicative ((<|>))
|
||||||
|
import Control.Monad.Reader (asks)
|
||||||
import qualified Data.Map as Map (lookup)
|
import qualified Data.Map as Map (lookup)
|
||||||
import Data.Text (Text, pack)
|
import Data.Text (Text, pack)
|
||||||
import Lucid (HtmlT, content_, meta_)
|
import Lucid (HtmlT, content_, meta_)
|
||||||
|
@ -46,8 +46,8 @@ make element siteURL = do
|
||||||
og "type" cardType
|
og "type" cardType
|
||||||
og "title" $ pack title
|
og "title" $ pack title
|
||||||
og "description" description
|
og "description" description
|
||||||
maybeImage =<< ((image <|>) <$> (Blog.get $skin.$cardImage))
|
maybeImage =<< ((image <|>) <$> (asks $skin.$cardImage))
|
||||||
og "site_name" =<< (Blog.get $name.$pack)
|
og "site_name" =<< (asks $name.$pack)
|
||||||
where
|
where
|
||||||
maybeImage = maybe (return ()) (og "image" . pack . (siteURL++))
|
maybeImage = maybe (return ()) (og "image" . pack . (siteURL++))
|
||||||
|
|
||||||
|
@ -62,7 +62,7 @@ instance HasCard Article.Article where
|
||||||
, urlPath = "/articles/" ++ title ++ ".html"
|
, urlPath = "/articles/" ++ title ++ ".html"
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
getDescription = maybe (Blog.get $name.$("A new article on " <>)) return
|
getDescription = maybe (asks $name.$("A new article on " <>)) return
|
||||||
|
|
||||||
instance HasCard ArticlesList where
|
instance HasCard ArticlesList where
|
||||||
getCard al@(ArticlesList {collection}) = do
|
getCard al@(ArticlesList {collection}) = do
|
||||||
|
|
|
@ -4,9 +4,8 @@ module JS (
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Blog (Blog(..), Path(..))
|
import Blog (Blog(..), Path(..))
|
||||||
import qualified Blog (get)
|
|
||||||
import Control.Monad.IO.Class (MonadIO(..))
|
import Control.Monad.IO.Class (MonadIO(..))
|
||||||
import Control.Monad.Reader (ReaderT)
|
import Control.Monad.Reader (ReaderT, asks)
|
||||||
import Data.ByteString.Lazy (ByteString, concat, readFile, writeFile)
|
import Data.ByteString.Lazy (ByteString, concat, readFile, writeFile)
|
||||||
import Data.ByteString.Lazy.Char8 (pack)
|
import Data.ByteString.Lazy.Char8 (pack)
|
||||||
import qualified Files (find)
|
import qualified Files (find)
|
||||||
|
@ -28,9 +27,9 @@ var (varName, content) = concat ["var ", pack varName, " = ", content, ";\n"]
|
||||||
|
|
||||||
generate :: ReaderT Blog IO ()
|
generate :: ReaderT Blog IO ()
|
||||||
generate = do
|
generate = do
|
||||||
destinationDir <- (</> "js") <$> (Blog.get $path.$root)
|
destinationDir <- (</> "js") <$> (asks $path.$root)
|
||||||
blogJSON <- exportBlog
|
blogJSON <- exportBlog
|
||||||
remarkablePath <- Blog.get $path.$remarkableConfig
|
remarkablePath <- asks $path.$remarkableConfig
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
remarkableJSON <- maybe (return "{html: true}") readFile remarkablePath
|
remarkableJSON <- maybe (return "{html: true}") readFile remarkablePath
|
||||||
let jsVars = var <$> [("blog", blogJSON), ("remarkableConfig", remarkableJSON)]
|
let jsVars = var <$> [("blog", blogJSON), ("remarkableConfig", remarkableJSON)]
|
||||||
|
|
Loading…
Reference in a new issue