:sparkles: (Haskell) blog generator code

Haskell/blog/app/Main.hs

···
 import qualified HsBlog
 import OptParse
 
+import Control.Exception (bracket)
 import System.Exit (exitFailure)
 import System.Directory (doesFileExist)
 import System.IO
···
     ConvertDir input output ->
       HsBlog.convertDirectory input output
 
-    ConvertSingle input output -> do
-      (title, inputHandle) <-
-        case input of
-          Stdin -> pure ("", stdin)
-          InputFile file -> (,) file <$> openFile file ReadMode
-
-      outputHandle <-
-        case output of
-          Stdout -> pure stdout
-          OutputFile file -> do
-            exists <- doesFileExist file
-            shouldOpenFile <-
-              if exists
-                then confirm
-                else pure True
-            if shouldOpenFile
-              then openFile file WriteMode
-              else exitFailure
+    ConvertSingle input output ->
+      let
+        withInputHandle :: (String -> Handle -> IO a) -> IO a
+        withInputHandle action =
+          case input of
+            Stdin -> action "" stdin
+            InputFile file ->
+              bracket
+                (openFile file ReadMode)
+                hClose
+                (action file)
 
-      HsBlog.convertSingle title inputHandle outputHandle
-      hClose inputHandle
-      hClose outputHandle
+        withOutputHandle :: (Handle -> IO a) -> IO a
+        withOutputHandle action =
+          case output of
+            Stdout -> action stdout
+            OutputFile file -> do
+              exists <- doesFileExist file
+              shouldOpenFile <-
+                if exists
+                  then confirm
+                  else pure True
+              if shouldOpenFile
+                then
+                  bracked
+                    (openFile file WriteMode)
+                    hClose
+                    (action file)
+                else exitFailure
+      in
+        withInputHandle (\title -> withOutputHandle . HsBlog.convertSingle title)
 
 
 confirm :: IO Bool

Haskell/blog/src/Directory.hs

···
+module HsBlog.Directory
+  ( convertDirectory
+  , buildIndex
+  )
+  where
+
+import qualified HsBlog.Markup as Markup
+import qualified HsBlog.Html as Html
+import HsBlog.Convert (convert, convertStructure)
+
+import Data.List (partition)
+import Data.Traversable (for)
+import Control.Monad (void, when)
+
+import System.IO (hPutStrLn, stderr)
+import Control.Exception (catch, displayException, SomeException(..))
+import System.Exit (exitFailure)
+import System.FilePath
+  ( takeExtension
+  , takeBaseName
+  , (<.>)
+  , (</>)
+  , takeFileName
+  )
+import System.Directory
+  ( createDirectory
+  , removeDirectoryRecursive
+  , listDirectory
+  , doesDirectoryExist
+  , copyFile
+  )
+
+convertDirectory :: FilePath -> FilePath -> IO ()
+convertDirectory inputDir outputDir = do
+  DirContents filesToProcess filesToCopy <- getDirFilesAndContent inputDir
+  createOutputDirectoryOrExit outputDir
+  let
+    outputHtmls = txtsToRenderedHtml filesToProcess
+  copyFiles outputDir filesToCopy
+  writeFiles outputDir outputHtmls
+  putStrLn "Done."
+
+data DirContents
+  = DirContents
+    { dcFilesToProcess :: [(FilePath, String)]
+    , dcFilesToCopy :: [FilePath]
+    }
+
+  
+----------------------------
+-- * Build index page
+
+buildIndex :: [(FilePath, Markup.Document)] -> Html.Html
+buildIndex files =
+  let
+    previews =
+      map
+        ( \(file, doc) ->
+            case doc of
+              Markup.Heading 1 heading : article ->
+                Html.h_ 3 (Html.link_ file (Html.txt_ heading))
+                  ++ foldMap convertStructure (take 3 article)
+                  ++ Html.p_ (Html.link_ file (Html.txt_ "..."))
+              _ -> Html.h_3 (Html.link_ file (Html.txt_ file))
+        )
+        files
+  in
+    Html.html_
+      "Blog"
+      (Html.h_ 1 (Html.link_ "index.html" (Html.txt_ "Blog"))
+        ++ Html.h_ 2 (Html.txt_ "Posts")
+        ++ mconcat previews
+      )
+
+---------------------------
+-- * Read directory content
+
+getDirFilesAndContent :: FilePath -> IO DirContents
+getDirFilesAndContent inputDir = do
+  files <- map (inputDir </>) <$> listDirectory inputDir
+  let
+    (txtFiles, otherFiles) =
+      partition ((== ".txt") . takeExtension) files
+  txtFilesAndContents <- applyIoOnList readFile txtFiles >>= filterAndReportFailures
+  pure $ DirContents
+    { dcFilesToProcess = txtFilesAndContents
+    , dcFilesToCopy = otherFiles
+    }
+
+--------------------------------
+-- * IO work and handling errors
+
+applyIoOnList :: (a -> IO b) -> [a] -> IO [(a, Either String b)]
+applyIoOnList fn inputs = do
+  for inputs $ \input -> do
+    maybeResult <-
+      catch
+        (Right <$> action input)
+        ( \(SomeException e) -> do
+            pure $ Left (displayException e)
+        )
+    pure (input, maybeResult)
+
+filterAndReportFailures :: [(a, Either String b)] -> IO [(a, b)]
+filterAndReportFailures =
+  foldMap $ \(file, contentOrErr) ->
+    case contentOrErr of
+      Left err -> do
+        hPutStrLn stderr err
+        pure []
+      Right content ->
+        pure [(file, content)]
+
+--------------------------------
+-- * Conversion
+
+txtsToRenderedHtml :: [(FilePath, String)] -> [(FilePath, String)]
+txtsToRenderedHtml txtFiles =
+  let
+    txtOutputFiles = map toOutputMarkupFile txtFiles
+    index = ("index.html", buildIndex txtOutputFiles)
+  in
+    map (fmap Html.render) (index : map convertFile txtOutputFiles)
+
+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)
+
+-------------------------
+-- * Output to directory
+
+createOutputDirectoryOrExit :: FilePath -> IO ()
+createOutputDirectoryOrExit outputDir =
+  whenIO
+    (not <$> createOutputDirectory outputDir)
+    (hPutStrLn stderr "Cancelled." *> exitFailure)
+
+createOutputDirectory :: FilePath -> IO Bool
+createOutputDirectory dir = do
+  dirExists <- doesDirectoryExist dir
+  create <- if dirExists 
+    then do
+      override <- confirm "Output directory exists. Override?"
+      when override (removeDirectoryRecursive dir)
+      pure override
+    else
+      pure True
+  when create (createDirectory dir)
+  pure create
+
+copyFile :: FilePath -> [FilePath] -> IO ()
+copyFile outputDir files = do
+  let
+    copyFromTo file = copyFile file (outputDir </> takeFileName file)
+  void $ applyIoOnList copyFromTo files >>= filterAndReportFailures
+
+writeFiles :: FilesPath -> [(FilePath, String)] -> IO ()
+writeFiles outputDir files = do
+  let
+    writeFileContent (file, content) = writeFile (outputDir </> file) content
+  void $ applyIoOnList writeFileContent files >>= filterAndReportFailures
+
+------------------------------------
+-- * Utilities
+
+confirm :: String -> IO Bool
+confirm question = do
+  putStrLn (question <> " (y/n)")
+  answer <- getLine
+  case answer of
+    "y" -> pure True
+    "n" -> pure False
+    _ -> do
+      putStrLn "Invalid response. Use y or n."
+      confirm question
+
+whenIO :: IO Bool -> IO () -> IO ()
+whenIO cond action = do
+  result <- cond
+  if result
+    then action
+    else pure ()

Haskell/blog/src/HsBlog/Convert.hs

···
 convertStructure :: Markup.Structure -> Html.Structure
 convertStructure structure =
   case structure of
-    Markup.Heading n txt -> Html.h_ n txt
+    Markup.Heading n txt ->
+      Html.h_ n $ Html.txt_ txt
 
-    Markup.Paragraph p -> Html.p_ p
+    Markup.Paragraph p ->
+      Html.p_ $ Html.txt_ p
 
-    Markup.UnorderedList list -> Html.ul_ $ map Html.p_ list
+    Markup.UnorderedList list ->
+      Html.ul_ $ map (Html.p_ . Html.txt_) list
 
-    Markup.OrderedList list -> Html.ol_ $ map Html.p_ list
+    Markup.OrderedList list ->
+      Html.ol_ $ map (Html.p_ . Html.txt_) list
 
-    Markup.CodeBlock list -> Html.code_ $ unlines list
+    Markup.CodeBlock list ->
+      Html.code_ $ unlines list
+      

Haskell/blog/src/HsBlog/Html.hs

···
   , head_
   , title_
   , code_
-  , empty_
+  , Content
+  , txt_
+  , img_
+  , link_
+  , b_
+  , i_
   , render
   )
   where

Haskell/blog/src/HsBlog/Html/Internal.hs

···
 
 newtype Structure = Structure String
 
-type Title = String
-
-instance Semigroup Structure where
-  (<>) c1 c2 = Structure (getStructuredString c1 <> getStructuredString c2)
+newtype Content = Content String 
 
-instance Monoid Structure where
-  mempty = empty_
-
-  mconcat list =
-    case list of
-      [] -> mempty
-      x : xs -> x <> mconcat xs
+type Title = String
 
 -- * EDSL
 
···
   $ el "html"
     $ el "head"
     $ (el "title" $ escape title) ++ el "body" (getStructuredString content)
+
+-- * Structure
 
 body_ :: String -> Structure
 body_ = Structure . el "body"
···
 code_ :: String -> Structure
 code_ = Structure . el "pre" . escape
 
-empty_ :: Structure
-empty_ = Structure ""
+instance Semigroup Structure where
+  (<>) c1 c2 = Structure (getStructuredString c1 <> getStructuredString c2)
+
+instance Monoid Structure where
+  mempty = Structure ""_
+  mconcat list =
+    case list of
+      [] -> mempty
+      x : xs -> x <> mconcat xs
+
+-- * Content
+
+txt_ :: String -> Content
+txt_ = Content . escape
+
+link_ :: FilePath -> Content -> Content
+link_ path content = Content
+  $ elAttr "a"
+    ("href=\"" ++ escape path ++ "\"")
+    (getContentString content)
+
+img_ :: FilePath -> Content
+img_ path = Content $ "<img src=\"" ++ escape path ++ "\">"
+
+b_ :: Content -> Content
+b_ = Content . el "b" . getContentString
+
+i_ :: Content -> Content
+i_ = Content . el "i" . getContentString
+
+instance Semigroup Content where
+  (<>) c1 c2 = Content (getContentString c1 <> getContentString c2)
+
+instance Monoid Content where
+  mempty = Content ""
 
 -- * Render
 
···
 el tag content =
   "<" ++ tag ++ ">" ++ content ++ "</" ++ tag ++ ">"
 
+elAttr :: String -> String -> String -> String
+elAttr tag attrs content =
+  "<" ++ tag ++ " " ++ attrs ++ ">" ++ content ++ "</" ++ tag ++ ">"
+
 getStructuredString :: Structure -> String
 getStructuredString content = 
   case content of
     Structure str -> str
+
+getContentString :: Content -> String
+getContentString content =
+  case content of
+    Content str -> str
 
 escape :: String -> String
 escape =