made logging in parsing more generic

This commit is contained in:
Pagwin 2025-11-16 14:51:19 -05:00
parent 53290132e7
commit b930a78f66
No known key found for this signature in database
GPG key ID: 81137023740CA260
4 changed files with 14 additions and 13 deletions

View file

@ -29,7 +29,7 @@ import Utilities
main :: IO () main :: IO ()
main = do main = do
Shake.shakeArgs Shake.shakeOptions $ do Shake.shakeArgs Shake.shakeOptions {Shake.shakeProgress = Shake.progressSimple} $ do
Shake.withTargetDocs "Build the site" $ Shake.withTargetDocs "Build the site" $
"build" ~> buildSite "build" ~> buildSite
Shake.withTargetDocs "Clean the built site" $ Shake.withTargetDocs "Clean the built site" $

View file

@ -7,27 +7,28 @@ module Markdown where
import Control.Applicative (many, optional, some, (<|>)) import Control.Applicative (many, optional, some, (<|>))
import Control.Monad (guard, void) import Control.Monad (guard, void)
import Control.Monad.Trans.Class (lift)
import Data.Char (isAlpha) import Data.Char (isAlpha)
import Data.Functor.Identity (Identity)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Void (Void) import Data.Void (Void)
import IR import IR
import Logger (Logger (logDebug))
import Text.Megaparsec (ParsecT, anySingle, anySingleBut, between, choice, count, eof, manyTill, notFollowedBy, satisfy, skipSome, try, (<?>)) import Text.Megaparsec (ParsecT, anySingle, anySingleBut, between, choice, count, eof, manyTill, notFollowedBy, satisfy, skipSome, try, (<?>))
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import Text.Megaparsec.Char (alphaNumChar, char, digitChar, string) import Text.Megaparsec.Char (alphaNumChar, char, digitChar, string)
type ParserT m = ParsecT Void String m type ParserT m = ParsecT Void String m
type Parser = ParserT IO type Parser = ParserT Identity
log_ :: String -> Parser () log_ :: T.Text -> Parser ()
log_ = lift . putStrLn log_ = logDebug
logP :: (Show s) => Parser s -> Parser s logP :: (Show s) => Parser s -> Parser s
logP v = do logP v = do
underlying <- v underlying <- v
log_ $ show underlying logDebug $ T.show underlying
v v
anyChar :: Parser Char anyChar :: Parser Char
@ -331,7 +332,7 @@ plainTextNo disallow = do
log_ "a" log_ "a"
firstChar <- noneOf disallow <?> "Plain Text Initial Disallow" firstChar <- noneOf disallow <?> "Plain Text Initial Disallow"
log_ "b" log_ "b"
remChars <- manyTill (plainTextCharNo disallow) lineEnding <?> "Remaining Characters" remChars <- many $ notFollowedBy lineEnding *> plainTextCharNo disallow
pure $ Text $ T.map wspHandler $ T.pack $ firstChar : remChars pure $ Text $ T.map wspHandler $ T.pack $ firstChar : remChars
where where
wspHandler '\n' = ' ' wspHandler '\n' = ' '

View file

@ -2,7 +2,7 @@ module Utilities where
import Config import Config
import Control.Monad (filterM) import Control.Monad (filterM)
import Control.Monad.IO.Class (liftIO) import Data.Functor.Identity (Identity (runIdentity))
import Data.List (find) import Data.List (find)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@ -38,7 +38,7 @@ indexHtmlMarkdownSourcePath =
markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text) markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text)
markdownToHtml filePath = do markdownToHtml filePath = do
content <- Shake.readFile' filePath content <- Shake.readFile' filePath
parse <- liftIO $ runParserT (liftA2 (,) Markdown.metadata Markdown.document) filePath content let parse = runIdentity $ runParserT (liftA2 (,) Markdown.metadata Markdown.document) filePath content
let (metadataText, document) = case parse of let (metadataText, document) = case parse of
Right (a, b) -> (a, b) Right (a, b) -> (a, b)
Left e -> error $ errorBundlePretty e Left e -> error $ errorBundlePretty e
@ -54,7 +54,7 @@ now = Shake.liftIO $ fmap (T.pack . iso8601Show) getCurrentTime
markdownToPost :: FilePath -> Action Post markdownToPost :: FilePath -> Action Post
markdownToPost path = do markdownToPost path = do
content <- Shake.readFile' path content <- Shake.readFile' path
parse <- liftIO $ runParserT Markdown.metadata path content let parse = runIdentity $ runParserT Markdown.metadata path content
let postData = case parse of let postData = case parse of
Right p -> p Right p -> p
Left e -> error $ errorBundlePretty e Left e -> error $ errorBundlePretty e

View file

@ -29,13 +29,13 @@ executable psb
-- .hs or .lhs file containing the Main module. -- .hs or .lhs file containing the Main module.
main-is: Main.hs main-is: Main.hs
other-modules: Config Utilities Templates Types IR Markdown Restruct HTML other-modules: Config Utilities Templates Types IR Markdown Restruct HTML Logger
default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
-- https://hackage.haskell.org/package/texmath -- https://hackage.haskell.org/package/texmath
build-depends: base >=4.17.2.1, mustache >=2.4.2, shake >= 0.19.8, deriving-aeson >= 0.2.9, aeson, text, time, unordered-containers, yaml, megaparsec >= 9.7.0, transformers >= 0.6.2 build-depends: base >=4.17.2.1, mustache >=2.4.2, shake >= 0.19.8, deriving-aeson >= 0.2.9, aeson, text >= 2.1.2, time, unordered-containers, yaml, megaparsec >= 9.7.0, transformers >= 0.6.2
--parsec >= 3.1.18.0 --parsec >= 3.1.18.0
-- Directories containing source files. -- Directories containing source files.