diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for Shakebook +## (v0.4.0.0) + +* Remove `SBConfig` and constraints from this library. This was only here for refactoring + convenience and creating a context should be up to the user. + ## (v0.3.1.0) * Add `withContent` lens. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -13,6 +13,7 @@ import Shakebook.Conventions import Shakebook.Mustache import Shakebook.Defaults +import Text.Pandoc.Options import Within sample :: Parser SimpleOpts @@ -32,6 +33,28 @@ , ppp :: Int } +data BuildOpts = BuildOpts + { sbSrcDir :: Path Rel Dir + , sbOutDir :: Path Rel Dir + , sbBaseUrl :: Text + , sbMdRead :: ReaderOptions + , sbHtWrite :: WriterOptions + , sbPPP :: Int + } +data AppConfig = AppConfig + { _opts :: BuildOpts + , _lf :: LogFunc + } + +class HasBuildOpts a where + buildOptsL :: Lens' a BuildOpts + +instance HasLogFunc AppConfig where + logFuncL = lens _lf undefined + +instance HasBuildOpts AppConfig where + buildOptsL = lens _opts undefined + opts :: ParserInfo SimpleOpts opts = info (sample <**> helper) ( fullDesc @@ -43,21 +66,22 @@ (x :: SimpleOpts) <- execParser opts s' <- parseRelDir (srcDir x) o' <- parseRelDir (outDir x) - app $ SbConfig s' o' (T.pack $ baseUrl x) defaultMarkdownReaderOptions defaultHtml5WriterOptions (ppp x) id + app $ BuildOpts s' o' (T.pack $ baseUrl x) defaultMarkdownReaderOptions defaultHtml5WriterOptions (ppp x) -app :: SbConfig -> IO () +app :: BuildOpts -> IO () app sbc = do logOptions' <- logOptionsHandle stdout True lf <- newLogFunc logOptions' - let f = ShakebookEnv (fst lf) sbc + let f = AppConfig sbc (fst lf) shake shakeOptions $ do want ["all"] - runShakePlus f $ view sbConfigL >>= \SbConfig {..} -> do + runShakePlus f $ do + BuildOpts{..} <- view buildOptsL - readMDC <- newCache loadMarkdownAsJSON + readMDC <- newCache $ loadMarkdownAsJSON sbMdRead sbHtWrite postsC <- newCache $ \w -> do xs <- batchLoadWithin' w readMDC diff --git a/shakebook.cabal b/shakebook.cabal --- a/shakebook.cabal +++ b/shakebook.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 57aeb1237df591d9d22b7ea05fc33ead1a5892537f1cc077b6f2df5853ada8d7 +-- hash: 468c86683bdf3cc44a2aaa53465f140ee14fe822330207c10c6e16febcbd3b35 name: shakebook -version: 0.3.1.0 +version: 0.4.0.0 synopsis: Shake-based technical documentation generator; HTML & PDF description: Shakebook is a documentation generator aimed at covering all the bases for mathematical, technical and scientific diagrams and typesetting. Shakebook provides combinators for taking markdown files and combining them into documents, but allowing the user to control how. Shakebook provides general combinators for templating single pages, cofree comonads for representing tables of contents, and zipper comonads for representing pagers. category: Web diff --git a/src/Shakebook/Conventions.hs b/src/Shakebook/Conventions.hs --- a/src/Shakebook/Conventions.hs +++ b/src/Shakebook/Conventions.hs @@ -233,13 +233,7 @@ . withJSON (genLinkData x (f x)) . withPosts (extract xs) $ Object mempty -genPageDataM :: (MonadReader r m, HasSbConfig r) => Text -> (Text -> Text) -> Zipper [] [Value] -> m Value -genPageDataM t f xs = view sbConfigL >>= \SbConfig{..} -> do - let z = genPageData t f xs - return $ sbGlobalApply z - - -genIndexPageData :: (MonadReader r m, HasSbConfig r, MonadThrow m) +genIndexPageData :: MonadThrow m => [Value] -> Text -> (Text -> Text) @@ -247,4 +241,4 @@ -> m (Zipper [] Value) genIndexPageData xs g h n = do zs <- paginate' n xs - sequence $ extend (genPageDataM g h) zs + return $ extend (genPageData g h) zs diff --git a/src/Shakebook/Data.hs b/src/Shakebook/Data.hs --- a/src/Shakebook/Data.hs +++ b/src/Shakebook/Data.hs @@ -30,30 +30,6 @@ display [] = "" display (x : xs) = display x <> " : " <> display xs -data SbConfig = SbConfig - { sbSrcDir :: Path Rel Dir - , sbOutDir :: Path Rel Dir - , sbBaseUrl :: Text - , sbMdRead :: ReaderOptions - , sbHTWrite :: WriterOptions - , sbPPP :: Int - , sbGlobalApply :: Value -> Value - } - -data ShakebookEnv = ShakebookEnv - { logFunc :: LogFunc - , sbConfig :: SbConfig - } - -class HasSbConfig a where - sbConfigL :: Lens' a SbConfig - -instance HasSbConfig ShakebookEnv where - sbConfigL = lens sbConfig undefined - -instance HasLogFunc ShakebookEnv where - logFuncL = lens logFunc undefined - -- | View the "content" field of a JSON value. viewContent :: Value -> Text viewContent = view (key "content" . _String) @@ -106,9 +82,6 @@ enrichUrl :: (Text -> Text) -> Value -> Value enrichUrl f v = withUrl (f (viewSrcPath v)) v -leadingSlash :: Path Abs Dir -leadingSlash = $(mkAbsDir "/") - withHtmlExtension :: MonadThrow m => Path Rel File -> m (Path Rel File) withHtmlExtension = replaceExtension ".html" @@ -118,32 +91,35 @@ withHaskellExtension :: MonadThrow m => Path Rel File -> m (Path Rel File) withHaskellExtension = replaceExtension ".hs" -generateSupposedUrl :: MonadThrow m => Path Rel File -> m (Path Abs File) -generateSupposedUrl srcPath = (leadingSlash ) <$> withHtmlExtension srcPath +toGroundedUrl :: Path Rel File -> Text +toGroundedUrl = T.pack . toFilePath . ($(mkAbsDir "/") ) +generateSupposedUrl :: MonadThrow m => Path Rel File -> m Text +generateSupposedUrl srcPath = toGroundedUrl <$> withHtmlExtension srcPath + enrichSupposedUrl :: MonadThrow m => Value -> m Value enrichSupposedUrl v = do x <- parseRelFile $ T.unpack $ viewSrcPath v y <- generateSupposedUrl x - return $ withUrl (T.pack . toFilePath $ y) v + return $ withUrl y v {-| Get a JSON Value of Markdown Data with markdown body as "contents" field and the srcPath as "srcPath" field. -} -loadMarkdownAsJSON :: (MonadReader r m, HasSbConfig r, MonadAction m, MonadThrow m) - => Within Rel (Path Rel File) - -> m Value -loadMarkdownAsJSON srcPath = view sbConfigL >>= \SbConfig{..} -> do - pdoc@(Pandoc meta _) <- readMDFileWithin sbMdRead srcPath - meta' <- flattenMeta (writeHtml5String sbHTWrite) meta - needPandocImagesIn sbOutDir pdoc - outText <- runPandocA $ writeHtml5String sbHTWrite pdoc +loadMarkdownAsJSON :: (MonadAction m, MonadThrow m) + => ReaderOptions + -> WriterOptions + -> Within Rel (Path Rel File) + -> m Value +loadMarkdownAsJSON ropts wopts srcPath = do + pdoc@(Pandoc meta _) <- readMDFileWithin ropts srcPath + meta' <- flattenMeta (writeHtml5String wopts) meta + outText <- runPandocA $ writeHtml5String wopts pdoc supposedUrl <- generateSupposedUrl (extract srcPath) - return $ sbGlobalApply - . withContent outText + return $ withContent outText . withSrcPath (T.pack . toFilePath $ extract srcPath) - . withUrl (T.pack . toFilePath $ supposedUrl) $ meta' + . withUrl supposedUrl $ meta' immediateShoots :: Cofree [] a -> [a] immediateShoots(_ :< xs) = extract <$> xs diff --git a/src/Shakebook/Defaults.hs b/src/Shakebook/Defaults.hs --- a/src/Shakebook/Defaults.hs +++ b/src/Shakebook/Defaults.hs @@ -1,19 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} module Shakebook.Defaults where -import Control.Comonad.Cofree -import Control.Monad.Extra import Data.Aeson as A -import Development.Shake.Plus import RIO -import qualified RIO.ByteString.Lazy as LBS import qualified RIO.Map as M import qualified RIO.Text as T import RIO.Time -import Path as P +import Path import Shakebook.Conventions -import Shakebook.Data -import Shakebook.Pandoc import Text.DocTemplates import Text.Pandoc.Definition import Text.Pandoc.Options @@ -53,13 +47,7 @@ defaultVideoReplacement :: Text -> Text -> Inline defaultVideoReplacement baseUrl = \x -> Str $ "[Video available at [" <> baseUrl <> "/" <> x <> "]" ---- | Build a PDF from a Cofree table of contents. -buildPDF :: (MonadThrow m, MonadAction m, MonadReader r m, HasSbConfig r) => Cofree [] (Path Rel File) -> Path Rel File -> FilePath -> m () -buildPDF toc meta out = view sbConfigL >>= \SbConfig {..} -> do - k <- mapM (readMDFileIn sbMdRead sbSrcDir) toc - a <- readMDFileIn sbMdRead sbSrcDir meta - z <- replaceUnusableImages [".mp4"] (defaultVideoReplacement sbBaseUrl) $ foldr (<>) a $ progressivelyDemoteHeaders k - needPandocImagesIn sbOutDir z - let z' = prefixAllImages sbOutDir z - f <- makePDFLaTeX defaultLatexWriterOptions z' - either (throwM . PandocActionException . show) (LBS.writeFile out) f +defaultPagePaths :: MonadThrow m => [Int] -> m [Path Rel File] +defaultPagePaths xs = do + xs' <- mapM (parseRelDir . show) xs + return $ fmap (\i -> $(mkRelDir "pages") i $(mkRelFile "index.html")) xs' diff --git a/src/Shakebook/Pandoc.hs b/src/Shakebook/Pandoc.hs --- a/src/Shakebook/Pandoc.hs +++ b/src/Shakebook/Pandoc.hs @@ -63,10 +63,12 @@ f _ = [] -- | Make a pdflatex in an `Action`. -makePDFLaTeX :: (MonadAction m, MonadThrow m) => WriterOptions -> Pandoc -> m (Either LBS.ByteString LBS.ByteString) -makePDFLaTeX wopts p = runPandocA $ do - t <- compileDefaultTemplate "latex" - makePDF "pdflatex" [] writeLaTeX wopts { writerTemplate = Just t } p +makePDFLaTeX :: (MonadAction m, MonadThrow m) => WriterOptions -> Pandoc -> m LBS.ByteString +makePDFLaTeX wopts p = do + f <- runPandocA $ do + t <- compileDefaultTemplate "latex" + makePDF "pdflatex" [] writeLaTeX wopts { writerTemplate = Just t } p + either (throwM . PandocActionException . show) return f -- | Precarious function that demotes Header numbers within the Pandoc according to its depth -- in the Cofree. This is so that Headers that H1s that would correctly display for an HTML page diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -31,8 +31,8 @@ outputFolder :: Path Rel Dir outputFolder = $(mkRelDir "test/public") -baseUrl :: Text -baseUrl = "http://blanky.test" +--baseUrl :: Text +--baseUrl = "http://blanky.test" siteTitle :: Text siteTitle = "Blanky Site" @@ -48,8 +48,8 @@ numRecentPosts :: Int numRecentPosts = 3 ---numPageNeighbours :: Int ---numPageNeighbours = 1 +numPageNeighbours :: Int +numPageNeighbours = 1 postsPerPage :: Int postsPerPage = 5 @@ -58,24 +58,11 @@ mySocial = uncurry genLinkData <$> [("twitter", "http://twitter.com/blanky-site-nowhere") ,("youtube", "http://youtube.com/blanky-site-nowhere") ,("gitlab", "http://gitlab.com/blanky-site-nowhere")] -sbc :: SbConfig -sbc = SbConfig { - sbSrcDir = sourceFolder -, sbOutDir = outputFolder -, sbBaseUrl = baseUrl -, sbMdRead = defaultMarkdownReaderOptions -, sbHTWrite = defaultHtml5WriterOptions -, sbPPP = postsPerPage -, sbGlobalApply = withSiteTitle siteTitle . withHighlighting pygments . withSocialLinks mySocial -} -pagePaths :: MonadThrow m => (Path Rel Dir -> Path Rel File) -> Zipper [] [a] -> m [Path Rel File] -pagePaths f xs = forM [1..size xs] $ parseRelDir . show >=> return . f - -rules :: ShakePlus ShakebookEnv () -rules = view sbConfigL >>= \SbConfig {..} -> do +rules :: HasLogFunc r => ShakePlus r () +rules = do - readMDC <- newCache loadMarkdownAsJSON + readMDC <- newCache $ loadMarkdownAsJSON defaultMarkdownReaderOptions defaultHtml5WriterOptions postsC <- newCache $ \w -> do xs <- batchLoadWithin' w readMDC @@ -95,114 +82,121 @@ (T.pack . defaultPrettyMonthFormat) (defaultMonthUrlFragment) (HM.elems allPosts) - let myPosts = ["posts/*.md"] `within` sbSrcDir + let myPosts = ["posts/*.md"] `within` sourceFolder - ("index.html" `within` sbOutDir) %^> \out -> do - src <- blinkAndMapM sbSrcDir withMarkdownExtension $ out + myBuildPage tmpl v out = do + rs <- getRecentPosts myPosts + let v' = withHighlighting pygments + . withSocialLinks mySocial + . withSiteTitle siteTitle + . withRecentPosts rs $ v + buildPageActionWithin (tmpl `within` sourceFolder) v' out + + + ("index.html" `within` outputFolder) %^> \out -> do + src <- blinkAndMapM sourceFolder withMarkdownExtension $ out v <- readMDC src - r <- getRecentPosts myPosts - let v' = withRecentPosts r v - buildPageActionWithin ($(mkRelFile "templates/index.html") `within` sbSrcDir) v' out + myBuildPage $(mkRelFile "templates/index.html") v out - ("posts/*.html" `within` sbOutDir) %^> \out -> do - src <- blinkAndMapM sbSrcDir withMarkdownExtension $ out + ("posts/*.html" `within` outputFolder) %^> \out -> do + src <- blinkAndMapM sourceFolder withMarkdownExtension $ out xs <- sortedPosts myPosts let k = elemIndex src (fst <$> xs) let z = fromJust $ liftA2 seek k $ zipper (snd <$> xs) - r <- getRecentPosts myPosts n <- getBlogNavbar myPosts - let v' = withRecentPosts r . withJSON n $ (extract z) - buildPageActionWithin ($(mkRelFile "templates/post.html") `within` sbSrcDir) v' out + let v' = withJSON n $ (extract z) + myBuildPage $(mkRelFile "templates/post.html") v' out - toc' <- mapM (mapM withHtmlExtension) $ fmap (`within` sbOutDir) tableOfContents + toc' <- mapM (mapM withHtmlExtension) $ fmap (`within` outputFolder) tableOfContents void . sequence . flip extend toc' $ \xs -> (fmap toFilePath $ extract xs) %^> \out -> do - let getDoc = readMDC <=< blinkAndMapM sbSrcDir withMarkdownExtension + let getDoc = readMDC <=< blinkAndMapM sourceFolder withMarkdownExtension ys <- mapM getDoc toc' zs <- mapM getDoc $ (immediateShoots xs) v <- getDoc $ out let v' = withJSON (genTocNavbarData ys) . withSubsections zs $ v - buildPageActionWithin ($(mkRelFile "templates/docs.html") `within` sbSrcDir) v' out + myBuildPage $(mkRelFile "templates/docs.html") v' out - ("posts/index.html" `within` sbOutDir) %^> - copyFileChangedWithin ($(mkRelFile "posts/pages/1/index.html") `within` sbOutDir) + ("posts/index.html" `within` outputFolder) %^> + copyFileChangedWithin ($(mkRelFile "posts/pages/1/index.html") `within` outputFolder) - ("posts/pages/*/index.html" `within` sbOutDir) %^> \out -> do + ("posts/pages/*/index.html" `within` outputFolder) %^> \out -> do xs <- sortedPosts myPosts let n = (+ (-1)) . read . (!! 2) . splitOn "/" . toFilePath . extract $ out - p <- seek n <$> genIndexPageData (snd <$> xs) "Posts" ("/posts/pages" <>) sbPPP + p <- seek n <$> genIndexPageData (snd <$> xs) "Posts" ("/posts/pages/" <>) postsPerPage k <- getBlogNavbar myPosts - let v = withJSON k $ extract p - buildPageActionWithin ($(mkRelFile "templates/post-list.html") `within` sbSrcDir) v out + let v = withJSON k $ extract $ extendPageNeighbours numPageNeighbours p + myBuildPage $(mkRelFile "templates/post-list.html") v out - ("posts/tags/*/index.html" `within` sbOutDir) %^> \out -> do + ("posts/tags/*/index.html" `within` outputFolder) %^> \out -> do let t = (!! 2) . splitOn "/" . toFilePath . extract $ out i <- parseRelFile $ "posts/tags/" <> t <> "/pages/1/index.html" - copyFileChangedWithin (i `within` sbOutDir) out + copyFileChangedWithin (i `within` outputFolder) out - ("posts/tags/*/pages/*/index.html" `within` sbOutDir) %^> \out -> do + ("posts/tags/*/pages/*/index.html" `within` outputFolder) %^> \out -> do let t = T.pack . (!! 2) . splitOn "/" . toFilePath . extract $ out xs <- filter (elem t . viewTags . snd) <$> sortedPosts myPosts let n = (+ (-1)) . read . (!! 4) . splitOn "/" . toFilePath . extract $ out - p <- seek n <$> genIndexPageData (snd <$> xs) ("Posts tagged " <> t) (("/posts/tags/" <> t <> "/posts") <>) sbPPP + p <- seek n <$> genIndexPageData (snd <$> xs) ("Posts tagged " <> t) (("/posts/tags/" <> t <> "/pages/") <>) postsPerPage k <- getBlogNavbar myPosts - let v = withJSON k $ extract p - buildPageActionWithin ($(mkRelFile "templates/post-list.html") `within` sbSrcDir) v out + let v = withJSON k $ extract $ extendPageNeighbours numPageNeighbours p + myBuildPage $(mkRelFile "templates/post-list.html") v out - ("posts/months/*/index.html" `within` sbOutDir) %^> \out -> do + ("posts/months/*/index.html" `within` outputFolder) %^> \out -> do let t = (!! 2) . splitOn "/" . toFilePath . extract $ out i <- parseRelFile $ "posts/months/" <> t <> "/pages/1/index.html" - copyFileChangedWithin (i `within` sbOutDir) out + copyFileChangedWithin (i `within` outputFolder) out - ("posts/months/*/pages/*/index.html" `within` sbOutDir) %^> \out -> do + ("posts/months/*/pages/*/index.html" `within` outputFolder) %^> \out -> do let t = parseISODateTime . T.pack . (!! 2) . splitOn "/" . toFilePath . extract $ out xs <- filter (sameMonth t . viewPostTime . snd) <$> sortedPosts myPosts let n = (+ (-1)) . read . (!! 4) . splitOn "/" . toFilePath . extract $ out p <- seek n <$> genIndexPageData (snd <$> xs) (("Posts from " <>) . T.pack . defaultPrettyMonthFormat $ t) - (("/posts/months/" <> T.pack (defaultMonthUrlFormat t) <> "/posts") <>) sbPPP + (("/posts/months/" <> T.pack (defaultMonthUrlFormat t) <> "/pages/") <>) postsPerPage k <- getBlogNavbar myPosts - let v = withJSON k $ extract p - buildPageActionWithin ($(mkRelFile "templates/post-list.html") `within` sbSrcDir) v out + let v = withJSON k $ extract $ extendPageNeighbours numPageNeighbours p + myBuildPage $(mkRelFile "templates/post-list.html") v out phony "index" $ - needIn sbOutDir [$(mkRelFile "index.html")] + needIn outputFolder [$(mkRelFile "index.html")] phony "post-index" $ do xs <- sortedPosts myPosts - needIn sbOutDir [$(mkRelFile "posts/index.html")] - paginate' sbPPP xs - >>= pagePaths (\p -> $(mkRelDir "posts/pages") p $(mkRelFile "index.html")) - >>= needIn sbOutDir + ps <- paginate' postsPerPage xs + fs <- defaultPagePaths [1..size ps] + needIn (outputFolder $(mkRelDir "posts")) ($(mkRelFile "index.html") : fs) phony "by-tag-index" $ do xs <- sortedPosts myPosts forM_ (viewAllPostTags (snd <$> xs)) $ \t -> do u <- parseRelDir $ T.unpack t - needIn sbOutDir [$(mkRelDir "posts/tags") u $(mkRelFile "index.html")] - paginate' sbPPP xs - >>= pagePaths (\p -> $(mkRelDir "posts/tags") u $(mkRelDir "pages") p $(mkRelFile "index.html")) - >>= needIn sbOutDir + let xs' = filter (elem t . viewTags . snd) xs + ps <- paginate' postsPerPage xs' + fs <- defaultPagePaths [1..size ps] + let tagFolder = outputFolder $(mkRelDir "posts/tags") u + needIn tagFolder ($(mkRelFile "index.html") : fs) phony "by-month-index" $ do xs <- sortedPosts myPosts forM_ (viewAllPostTimes (snd <$> xs)) $ \t -> do u <- parseRelDir $ defaultMonthUrlFormat t - needIn sbOutDir [$(mkRelDir "posts/months") u $(mkRelFile "index.html")] - paginate' sbPPP xs - >>= pagePaths (\p -> $(mkRelDir "posts/months") u $(mkRelDir "pages") p $(mkRelFile "index.html")) - >>= needIn sbOutDir + let monthFolder = outputFolder $(mkRelDir "posts/months") u + let xs' = filter (sameMonth t . viewPostTime . snd) xs + ps <- paginate' postsPerPage xs' + fs <- defaultPagePaths [1..size ps] + needIn monthFolder ($(mkRelFile "index.html") : fs) phony "docs" $ - mapM withHtmlExtension tableOfContents >>= needIn sbOutDir + mapM withHtmlExtension tableOfContents >>= needIn outputFolder phony "posts" $ - getDirectoryFilesWithin' (["posts/*.md"] `within` sbSrcDir) >>= - mapM (blinkAndMapM sbOutDir withHtmlExtension) >>= + getDirectoryFilesWithin' (["posts/*.md"] `within` sourceFolder) >>= + mapM (blinkAndMapM outputFolder withHtmlExtension) >>= needWithin' phony "clean" $ do - logInfo $ "Cleaning files in " <> display (PathDisplay sbOutDir) - removeFilesAfter sbOutDir ["//*"] + logInfo $ "Cleaning files in " <> display (PathDisplay outputFolder) + removeFilesAfter outputFolder ["//*"] tests :: [FilePath] -> TestTree tests xs = testGroup "Rendering Tests" $ @@ -215,9 +209,8 @@ main = do xs <- findByExtension [".html"] "test/golden" logOptions' <- logOptionsHandle stdout True - lf <- newLogFunc (setLogMinLevel LevelInfo logOptions') - let f = ShakebookEnv (fst lf) sbc - shake shakeOptions $ want ["clean"] >> runShakePlus f rules - shake shakeOptions $ want ["index", "docs", "posts", "post-index", "by-tag-index", "by-month-index"] >> runShakePlus f rules--, "docs", "month-index", "posts-index", "tag-index", "posts"] >> runShakePlus f rules + (lf, dlf) <- newLogFunc (setLogMinLevel LevelInfo logOptions') + shake shakeOptions $ want ["clean"] >> runShakePlus lf rules + shake shakeOptions $ want ["index", "docs", "posts", "post-index", "by-tag-index", "by-month-index"] >> runShakePlus lf rules defaultMain $ tests xs - snd lf + dlf