From f9fe7179fcf0e6c818f6caa860b52e991432dab2 Mon Sep 17 00:00:00 2001 From: Gil Mizrahi Date: Mon, 24 Jan 2022 15:27:29 +0200 Subject: [PATCH] Chapter 7 - Environment --- app/Main.hs | 4 ++-- app/OptParse.hs | 34 ++++++++++++++++++++++++++++++++-- hs-blog.cabal | 2 ++ src/HsBlog.hs | 7 ++++--- src/HsBlog/Convert.hs | 18 ++++++++++++++++-- src/HsBlog/Directory.hs | 36 +++++++++++++++++++++--------------- src/HsBlog/Env.hs | 13 +++++++++++++ src/HsBlog/Html.hs | 5 ++++- src/HsBlog/Html/Internal.hs | 31 ++++++++++++++++++++++++++----- 9 files changed, 120 insertions(+), 30 deletions(-) create mode 100644 src/HsBlog/Env.hs diff --git a/app/Main.hs b/app/Main.hs index 341e479..1e5e49d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -15,8 +15,8 @@ main :: IO () main = do options <- parse case options of - ConvertDir input output -> - HsBlog.convertDirectory input output + ConvertDir input output env -> + HsBlog.convertDirectory env input output ConvertSingle input output -> do (title, inputHandle) <- diff --git a/app/OptParse.hs b/app/OptParse.hs index 9c3803f..5263245 100644 --- a/app/OptParse.hs +++ b/app/OptParse.hs @@ -11,6 +11,7 @@ module OptParse where import Data.Maybe (fromMaybe) +import HsBlog.Env import Options.Applicative ------------------------------------------------ @@ -19,7 +20,7 @@ import Options.Applicative -- | Model data Options = ConvertSingle SingleInput SingleOutput - | ConvertDir FilePath FilePath + | ConvertDir FilePath FilePath Env deriving Show -- | A single input source @@ -114,7 +115,7 @@ pOutputFile = OutputFile <$> parser pConvertDir :: Parser Options pConvertDir = - ConvertDir <$> pInputDir <*> pOutputDir + ConvertDir <$> pInputDir <*> pOutputDir <*> pEnv -- | Parser for input directory pInputDir :: Parser FilePath @@ -135,3 +136,32 @@ pOutputDir = <> metavar "DIRECTORY" <> help "Output directory" ) + +-- | Parser for blog environment +pEnv :: Parser Env +pEnv = + Env <$> pBlogName <*> pStylesheet + +-- | Blog name parser +pBlogName :: Parser String +pBlogName = + strOption + ( long "name" + <> short 'N' + <> metavar "STRING" + <> help "Blog name" + <> value (eBlogName defaultEnv) + <> showDefault + ) + +-- | Stylesheet parser +pStylesheet :: Parser String +pStylesheet = + strOption + ( long "style" + <> short 'S' + <> metavar "FILE" + <> help "Stylesheet filename" + <> value (eStylesheetPath defaultEnv) + <> showDefault + ) diff --git a/hs-blog.cabal b/hs-blog.cabal index cddfadc..2c190a0 100644 --- a/hs-blog.cabal +++ b/hs-blog.cabal @@ -33,10 +33,12 @@ library base , directory , filepath + , mtl exposed-modules: HsBlog HsBlog.Convert HsBlog.Directory + HsBlog.Env HsBlog.Html HsBlog.Html.Internal HsBlog.Markup diff --git a/src/HsBlog.hs b/src/HsBlog.hs index 8c8ef57..4e9ad5e 100644 --- a/src/HsBlog.hs +++ b/src/HsBlog.hs @@ -12,13 +12,14 @@ import qualified HsBlog.Markup as Markup import qualified HsBlog.Html as Html import HsBlog.Convert (convert) import HsBlog.Directory (convertDirectory, buildIndex) +import HsBlog.Env (defaultEnv) import System.IO -convertSingle :: Html.Title -> Handle -> Handle -> IO () +convertSingle :: String -> Handle -> Handle -> IO () convertSingle title input output = do content <- hGetContents input hPutStrLn output (process title content) -process :: Html.Title -> String -> String -process title = Html.render . convert title . Markup.parse +process :: String -> String -> String +process title = Html.render . convert defaultEnv title . Markup.parse diff --git a/src/HsBlog/Convert.hs b/src/HsBlog/Convert.hs index e78710d..0283753 100644 --- a/src/HsBlog/Convert.hs +++ b/src/HsBlog/Convert.hs @@ -2,11 +2,25 @@ module HsBlog.Convert where +import Prelude hiding (head) +import HsBlog.Env (Env(..)) import qualified HsBlog.Markup as Markup import qualified HsBlog.Html as Html -convert :: Html.Title -> Markup.Document -> Html.Html -convert title = Html.html_ title . foldMap convertStructure +convert :: Env -> String -> Markup.Document -> Html.Html +convert env title doc = + let + head = + Html.title_ (eBlogName env <> " - " <> title) + <> Html.stylesheet_ (eStylesheetPath env) + article = + foldMap convertStructure doc + websiteTitle = + Html.h_ 1 (Html.link_ "index.html" $ Html.txt_ $ eBlogName env) + body = + websiteTitle <> article + in + Html.html_ head body convertStructure :: Markup.Structure -> Html.Structure convertStructure structure = diff --git a/src/HsBlog/Directory.hs b/src/HsBlog/Directory.hs index aa26746..1020ccb 100644 --- a/src/HsBlog/Directory.hs +++ b/src/HsBlog/Directory.hs @@ -11,10 +11,12 @@ module HsBlog.Directory import qualified HsBlog.Markup as Markup import qualified HsBlog.Html as Html import HsBlog.Convert (convert, convertStructure) +import HsBlog.Env (Env(..)) import Data.List (partition) import Data.Traversable (for) import Control.Monad (void, when) +import Control.Monad.Reader (Reader, runReader, ask) import System.IO (hPutStrLn, stderr) import Control.Exception (catch, displayException, SomeException(..)) @@ -38,12 +40,12 @@ import System.Directory -- '.html' files in the process. Recording unsuccessful reads and writes to stderr. -- -- May throw an exception on output directory creation. -convertDirectory :: FilePath -> FilePath -> IO () -convertDirectory inputDir outputDir = do +convertDirectory :: Env -> FilePath -> FilePath -> IO () +convertDirectory env inputDir outputDir = do DirContents filesToProcess filesToCopy <- getDirFilesAndContent inputDir createOutputDirectoryOrExit outputDir let - outputHtmls = txtsToRenderedHtml filesToProcess + outputHtmls = runReader (txtsToRenderedHtml filesToProcess) env copyFiles outputDir filesToCopy writeFiles outputDir outputHtmls putStrLn "Done." @@ -77,8 +79,9 @@ data DirContents ------------------------------------ -- * Build index page -buildIndex :: [(FilePath, Markup.Document)] -> Html.Html -buildIndex files = +buildIndex :: [(FilePath, Markup.Document)] -> Reader Env Html.Html +buildIndex files = do + env <- ask let previews = map @@ -92,9 +95,10 @@ buildIndex files = Html.h_ 3 (Html.link_ file (Html.txt_ file)) ) files - in - Html.html_ - "Blog" + pure $ Html.html_ + ( Html.title_ (eBlogName env) + <> Html.stylesheet_ (eStylesheetPath env) + ) ( Html.h_ 1 (Html.link_ "index.html" (Html.txt_ "Blog")) <> Html.h_ 2 (Html.txt_ "Posts") <> mconcat previews @@ -104,20 +108,22 @@ buildIndex files = -- * Conversion -- | Convert text files to Markup, build an index, and render as html. -txtsToRenderedHtml :: [(FilePath, String)] -> [(FilePath, String)] -txtsToRenderedHtml txtFiles = +txtsToRenderedHtml :: [(FilePath, String)] -> Reader Env [(FilePath, String)] +txtsToRenderedHtml txtFiles = do let txtOutputFiles = map toOutputMarkupFile txtFiles - index = ("index.html", buildIndex txtOutputFiles) - in - map (fmap Html.render) (index : map convertFile txtOutputFiles) + index <- (,) "index.html" <$> buildIndex txtOutputFiles + htmlPages <- traverse convertFile txtOutputFiles + pure $ map (fmap Html.render) (index : htmlPages) toOutputMarkupFile :: (FilePath, String) -> (FilePath, Markup.Document) toOutputMarkupFile (file, content) = (takeBaseName file <.> "html", Markup.parse content) -convertFile :: (FilePath, Markup.Document) -> (FilePath, Html.Html) -convertFile (file, doc) = (file, convert file doc) +convertFile :: (FilePath, Markup.Document) -> Reader Env (FilePath, Html.Html) +convertFile (file, doc) = do + env <- ask + pure (file, convert env (takeBaseName file) doc) ------------------------------------ -- * Output to directory diff --git a/src/HsBlog/Env.hs b/src/HsBlog/Env.hs new file mode 100644 index 0000000..0895969 --- /dev/null +++ b/src/HsBlog/Env.hs @@ -0,0 +1,13 @@ +-- | src/HsBlog/Env.hs + +module HsBlog.Env where + +data Env + = Env + { eBlogName :: String + , eStylesheetPath :: FilePath + } + deriving Show + +defaultEnv :: Env +defaultEnv = Env "My Blog" "style.css" diff --git a/src/HsBlog/Html.hs b/src/HsBlog/Html.hs index 239831c..65c9131 100644 --- a/src/HsBlog/Html.hs +++ b/src/HsBlog/Html.hs @@ -2,7 +2,10 @@ module HsBlog.Html ( Html - , Title + , Head + , title_ + , stylesheet_ + , meta_ , Structure , html_ , h_ diff --git a/src/HsBlog/Html/Internal.hs b/src/HsBlog/Html/Internal.hs index 1bd3e0e..ae895e7 100644 --- a/src/HsBlog/Html/Internal.hs +++ b/src/HsBlog/Html/Internal.hs @@ -2,6 +2,7 @@ module HsBlog.Html.Internal where +import Prelude hiding (head) import Numeric.Natural -- * Types @@ -15,20 +16,40 @@ newtype Structure newtype Content = Content String -type Title - = String +newtype Head + = Head String -- * EDSL -html_ :: Title -> Structure -> Html -html_ title content = +html_ :: Head -> Structure -> Html +html_ (Head head) content = Html ( el "html" - ( el "head" (el "title" (escape title)) + ( el "head" head <> el "body" (getStructureString content) ) ) +-- * Head + +title_ :: String -> Head +title_ = Head . el "title" . escape + +stylesheet_ :: FilePath -> Head +stylesheet_ path = + Head $ " escape path <> "\">" + +meta_ :: String -> String -> Head +meta_ name content = + Head $ " escape name <> "\" content=\"" <> escape content <> "\">" + +instance Semigroup Head where + (<>) (Head h1) (Head h2) = + Head (h1 <> h2) + +instance Monoid Head where + mempty = Head "" + -- * Structure p_ :: Content -> Structure