refactored Utilties to split off FilePath and Action functions into their own files among other refactoring

app/Main.hs

@@ -21,7 +21,8 @@ import Development.Shake.FilePath ((</>))
 import qualified Development.Shake.FilePath as FP
 import Templates
 import Types
-import Utilities
+import Utilities.Action (getPublishedPosts, isDraft', markdownToHtml, markdownToPost, now)
+import Utilities.FilePath (indexHtmlOutputPath, indexHtmlSourcePaths, isMarkdownPost, urlConvert)
 
 -- target = thing we want
 -- Rule = pattern of thing being made + actions to produce the thing
@@ -47,7 +48,7 @@ buildSite = do
   Shake.need $ map indexHtmlOutputPath pagePaths
 
   -- handle posts
-  postPaths <- getPublishedPosts
+  postPaths <- getPublishedPosts isDraft
   Shake.need $ map indexHtmlOutputPath postPaths
 
   -- remaining pages, index.xml = rss feed
@@ -95,7 +96,7 @@ markdownPost src = do
   let rPost = fromPost post
   postHtml <- applyTemplate "post.html" rPost
 
-  time <- Utilities.now
+  time <- Utilities.Action.now
   -- Shake.putInfo $ T.unpack $ urlConvert target
   let page =
         Page
@@ -111,13 +112,13 @@ markdownPost src = do
 home :: Rules ()
 home =
   outputDir </> "index.html" %> \target -> do
-    postPaths <- getPublishedPosts
+    postPaths <- getPublishedPosts isDraft
     posts <-
       sortOn (Ord.Down . postDate)
         <$> forM postPaths readPost
     let posts' = map fromPost posts
     html <- applyTemplate "home.html" $ HM.singleton "posts" posts'
-    time <- Utilities.now
+    time <- Utilities.Action.now
     -- Shake.putInfo $ T.unpack $ urlConvert target
     let page =
           Page
@@ -140,9 +141,9 @@ data Rss = Rss
 rss :: Rules ()
 rss =
   outputDir </> "index.xml" %> \target -> do
-    postPaths <- getPublishedPosts
+    postPaths <- getPublishedPosts isDraft
     posts <- map fromPost . sortOn (Ord.Down . postDate) <$> forM postPaths readPost
-    time <- Utilities.now
+    time <- Utilities.Action.now
     applyTemplateAndWrite "feed.xml" (Rss time posts) target
 
 -- Shake.putInfo $ "Built " <> target
@@ -161,3 +162,9 @@ readMarkdownPost postPath = do
       { postContent = Just html,
         postLink = Just . T.pack $ "/" <> FP.dropExtension postPath <> "/"
       }
+
+postHandles :: [(FilePath -> Bool, FilePath -> Action Post)]
+postHandles = [(isMarkdownPost, markdownToPost)]
+
+isDraft :: FilePath -> Action Bool
+isDraft = isDraft' postHandles

app/Markdown.hs

@@ -17,16 +17,14 @@ import Logger (Logger (logDebug))
 import Text.Megaparsec (ParsecT, anySingle, anySingleBut, between, choice, count, eof, manyTill, notFollowedBy, satisfy, skipSome, try, (<?>))
 import qualified Text.Megaparsec as MP
 import Text.Megaparsec.Char (alphaNumChar, char, digitChar, string)
+import Utilities (tee)
 
 type ParserT m = ParsecT Void String m
 
 type Parser = ParserT Identity
 
 logP :: (Logger m, Show s) => ParserT m s -> ParserT m s
-logP v = do
-  underlying <- v
-  logDebug $ T.show underlying
-  v
+logP = tee (logDebug . T.show)
 
 anyChar :: ParserT m Char
 anyChar = anySingle

app/Utilities.hs

@@ -1,101 +1,14 @@
 module Utilities where
 
-import Config
-import Control.Monad (filterM)
-import Data.Functor.Identity (Identity (runIdentity))
-import Data.List (find)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
 import Data.Time
-import Data.Time.Format.ISO8601 (iso8601Show)
-import Data.Yaml.Aeson
-import Development.Shake (Action)
-import qualified Development.Shake as Shake
-import Development.Shake.FilePath ((<.>), (</>))
-import qualified Development.Shake.FilePath as FP
-import HTML
-import Markdown
-import Text.Megaparsec (errorBundlePretty, runParserT)
-import Types
-
-indexHtmlOutputPath :: FilePath -> FilePath
-indexHtmlOutputPath srcPath =
-  outputDir </> FP.dropExtension srcPath </> "index.html"
-
--- were applicative shenanigans necessary? no
--- but using them felt cool
-indexHtmlSourcePaths :: FilePath -> [FilePath]
-indexHtmlSourcePaths path = [indexHtmlMarkdownSourcePath] <*> [path]
-
-indexHtmlMarkdownSourcePath :: FilePath -> FilePath
-indexHtmlMarkdownSourcePath =
-  FP.dropDirectory1
-    . (<.> "md")
-    . FP.dropTrailingPathSeparator
-    . FP.dropFileName
-
-markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text)
-markdownToHtml filePath = do
-  content <- Shake.readFile' filePath
-  let parse = runIdentity $ runParserT (liftA2 (,) Markdown.metadata Markdown.document) filePath content
-  let (metadataText, document) = case parse of
-        Right (a, b) -> (a, b)
-        Left e -> error $ errorBundlePretty e
-
-  let metadata = case decodeEither' $ encodeUtf8 metadataText of
-        Right m -> m
-        Left e -> error $ show e
-  pure (metadata, compileToHTML document)
-
-now :: Action T.Text
-now = Shake.liftIO $ fmap (T.pack . iso8601Show) getCurrentTime
-
-markdownToPost :: FilePath -> Action Post
-markdownToPost path = do
-  content <- Shake.readFile' path
-  let parse = runIdentity $ runParserT Markdown.metadata path content
-  let postData = case parse of
-        Right p -> p
-        Left e -> error $ errorBundlePretty e
-  let post = case decodeEither' $ encodeUtf8 postData of
-        Right p -> p
-        Left e -> error $ show e
-  pure post
-
-yamlToPost :: FilePath -> Action Post
-yamlToPost path = do
-  post <- decodeFileThrow path
-  -- let post' = dateTransform post
-  return post
-
-isMarkdownPost :: FilePath -> Bool
-isMarkdownPost path = FP.takeExtension path == ".md"
-
-postHandles :: [(FilePath -> Bool, FilePath -> Action Post)]
-postHandles = [(isMarkdownPost, markdownToPost)]
-
-isDraft :: FilePath -> Action Bool
-isDraft path = do
-  let action =
-        case find (\(test, _) -> test path) postHandles of
-          (Just (_, action')) -> action'
-          Nothing -> error "no post handle for this file type"
-  post <- action path
-  return $ case postDraft post of
-    Just ret -> ret
-    Nothing -> (error $ "Missing draft attr: " ++ path)
-
-getPublishedPosts :: Action [FilePath]
-getPublishedPosts = do
-  postPaths <- Shake.getDirectoryFiles "" postGlobs
-  filterM (fmap not . isDraft) postPaths
 
 parseDate :: Text -> Maybe Text
 parseDate str = do
   date <- parseTimeM False defaultTimeLocale "%Y-%-m-%-d" $ T.unpack str
   -- need to append the time to avoid potential issues
-  return $ T.pack $ formatTime @UTCTime defaultTimeLocale "%Y-%m-%dT00:00:00Z" date
+  pure $ T.pack $ formatTime @UTCTime defaultTimeLocale "%Y-%m-%dT00:00:00Z" date
 
-urlConvert :: FilePath -> Text
-urlConvert = T.pack . FP.dropFileName . flip FP.replaceDirectory1 "https://pagwin.xyz"
+tee :: (Monad m) => (a -> m b) -> m a -> m a
+tee f v = v >>= (\underlying -> f underlying *> v)

app/Utilities/Action.hs

@@ -0,0 +1,62 @@
+module Utilities.Action where
+
+import Config (postGlobs)
+import Control.Monad (filterM)
+import Data.Functor.Identity (Identity (runIdentity))
+import Data.List (find)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time (getCurrentTime)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Data.Yaml.Aeson
+import Development.Shake (Action)
+import qualified Development.Shake as Shake
+import HTML
+import Markdown
+import Text.Megaparsec (errorBundlePretty, runParserT)
+import Types
+
+markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text)
+markdownToHtml filePath = do
+  content <- Shake.readFile' filePath
+  let parse = runIdentity $ runParserT (liftA2 (,) Markdown.metadata Markdown.document) filePath content
+  let (metadataText, document) = case parse of
+        Right (a, b) -> (a, b)
+        Left e -> error $ errorBundlePretty e
+
+  let metadata = case decodeEither' $ encodeUtf8 metadataText of
+        Right m -> m
+        Left e -> error $ show e
+  pure (metadata, compileToHTML document)
+
+markdownToPost :: FilePath -> Action Post
+markdownToPost path = do
+  content <- Shake.readFile' path
+  let parse = runIdentity $ runParserT Markdown.metadata path content
+  let postData = case parse of
+        Right p -> p
+        Left e -> error $ errorBundlePretty e
+  let post = case decodeEither' $ encodeUtf8 postData of
+        Right p -> p
+        Left e -> error $ show e
+  pure post
+
+now :: Action T.Text
+now = Shake.liftIO $ fmap (T.pack . iso8601Show) getCurrentTime
+
+isDraft' :: [(FilePath -> Bool, FilePath -> Action Post)] -> FilePath -> Action Bool
+isDraft' postHandles path = do
+  let action =
+        case find (\(test, _) -> test path) postHandles of
+          (Just (_, action')) -> action'
+          Nothing -> error "no post handle for this file type"
+  post <- action path
+  pure $ case postDraft post of
+    Just ret -> ret
+    Nothing -> (error $ "Missing draft attr: " ++ path)
+
+getPublishedPosts :: (FilePath -> Action Bool) -> Action [FilePath]
+getPublishedPosts draftCheck = do
+  postPaths <- Shake.getDirectoryFiles "" postGlobs
+  filterM (fmap not . draftCheck) postPaths

app/Utilities/FilePath.hs

@@ -0,0 +1,27 @@
+module Utilities.FilePath where
+
+import Config
+import Data.Text (Text)
+import qualified Data.Text as T
+import Development.Shake.FilePath ((<.>), (</>))
+import qualified Development.Shake.FilePath as FP
+
+indexHtmlOutputPath :: FilePath -> FilePath
+indexHtmlOutputPath srcPath =
+  outputDir </> FP.dropExtension srcPath </> "index.html"
+
+indexHtmlSourcePaths :: FilePath -> [FilePath]
+indexHtmlSourcePaths path = map ($ path) [indexHtmlMarkdownSourcePath]
+
+indexHtmlMarkdownSourcePath :: FilePath -> FilePath
+indexHtmlMarkdownSourcePath =
+  FP.dropDirectory1
+    . (<.> "md")
+    . FP.dropTrailingPathSeparator
+    . FP.dropFileName
+
+isMarkdownPost :: FilePath -> Bool
+isMarkdownPost path = FP.takeExtension path == ".md"
+
+urlConvert :: FilePath -> Text
+urlConvert = T.pack . FP.dropFileName . flip FP.replaceDirectory1 "https://pagwin.xyz"

psb.cabal

@@ -29,7 +29,7 @@ executable psb
     -- .hs or .lhs file containing the Main module.
     main-is:          Main.hs
 
-    other-modules: Config Utilities Templates Types IR Markdown Restruct HTML Logger
+    other-modules: Config Utilities Utilities.FilePath Utilities.Action Templates Types IR Markdown Restruct HTML Logger
 
     default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances