shakebook 0.2.0.4 → 0.2.2.0
raw patch · 10 files changed
+337/−270 lines, 10 filesdep +mustachedep +pathdep +shake-plusdep −comonad-extras
Dependencies added: mustache, path, shake-plus, within, zipper-extra
Dependencies removed: comonad-extras
Files
- ChangeLog.md +13/−0
- app/Main.hs +13/−8
- shakebook.cabal +18/−6
- src/Shakebook/Conventions.hs +5/−5
- src/Shakebook/Data.hs +76/−92
- src/Shakebook/Defaults.hs +155/−118
- src/Shakebook/Mustache.hs +43/−0
- src/Shakebook/Rules.hs +1/−1
- src/Shakebook/Zipper.hs +0/−29
- test/Spec.hs +13/−11
ChangeLog.md view
@@ -1,5 +1,18 @@ # Changelog for Shakebook +## (v0.2.2.0)++* Depend on new experimental library+ [shake-plus](https://hackage.haskell.org/package/shake-plus), that includes+re-exports of the Shake API based on the+[path](https://hackage.haskell.org/package/path) library for well-typed paths+and the [within](https://hackage.haskell.org/package/within) library which+introduces the `Within` type for representing a `Path` within a `Path`.+* Zipper functionality moved to external library+ [zipper-extra](https://hackage.haskell.org/package/zipper-extra).+* `Shakebook` and `ShakebookA` dropped in favour of `ShakePlus` and `RAction`+ from `shake-plus`.+ ## (v0.2.0.3) * Add logging to Shakebook's monads via RIO's logging methods.
app/Main.hs view
@@ -1,8 +1,9 @@+{-# LANGUAGE TemplateHaskell #-} module Main where -import Development.Shake-import Development.Shake.FilePath+import Development.Shake.Plus import Options.Applicative+import Path import RIO import qualified RIO.Text as T import Shakebook@@ -31,11 +32,15 @@ <> progDesc "Creates a simple blog from source with default settings." <> header "shakebook-simple-blog - A simple blog using standard shakebook conventions." ) +indexHTML :: Path Rel File+indexHTML = $(mkRelFile "index.html")+ main :: IO () main = do (x :: SimpleOpts) <- execParser opts-- app $ SbConfig (srcDir x) (outDir x) (T.pack $ baseUrl x) defaultMarkdownReaderOptions defaultHtml5WriterOptions (ppp x)+ s' <- parseRelDir (srcDir x)+ o' <- parseRelDir (outDir x)+ app $ SbConfig s' o' (T.pack $ baseUrl x) defaultMarkdownReaderOptions defaultHtml5WriterOptions (ppp x) app :: SbConfig -> IO () app sbc = do@@ -43,19 +48,19 @@ lf <- newLogFunc logOptions' let f = ShakebookEnv (fst lf) sbc - shake (shakeOptions { shakeVerbosity = Chatty, shakeLintInside = ["\\"] }) $ do+ shake shakeOptions $ do want ["all"] - runShakebook f $ view sbConfigL >>= \SbConfig {..} -> do+ runShakePlus f $ view sbConfigL >>= \SbConfig {..} -> do defaultCleanPhony defaultSinglePagePattern "index.html" "templates/index.html" (affixRecentPosts ["posts/md"] 5 defaultEnrichPost) - liftRules $ phony "index" $ need [sbOutDir </> "index.html"]+ phony "index" $ needP [sbOutDir </> indexHTML] - phony "all" $ need ["index"]+ phony "all" $ need ["index"] snd lf
shakebook.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f07d9fe04c2a84023b693534da2123af9c52934fba5c71935b6a93bb57ea1005+-- hash: 81875743197319be0e2b8ba86e21804725439f8864b08a8528d09354faeb63de name: shakebook-version: 0.2.0.4+version: 0.2.2.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@@ -29,8 +29,8 @@ Shakebook.Data Shakebook.Defaults Shakebook.Feed+ Shakebook.Mustache Shakebook.Rules- Shakebook.Zipper other-modules: Paths_shakebook hs-source-dirs:@@ -41,21 +41,25 @@ aeson , base >=4.7 && <5 , comonad- , comonad-extras , doctemplates , extra , feed , free , lens , lens-aeson+ , mustache , pandoc , pandoc-types+ , path , relude , rio , shake+ , shake-plus , slick , split , text-time+ , within+ , zipper-extra default-language: Haskell2010 executable shakebook-simple-blog@@ -70,23 +74,27 @@ aeson , base >=4.7 && <5 , comonad- , comonad-extras , doctemplates , extra , feed , free , lens , lens-aeson+ , mustache , optparse-applicative , pandoc , pandoc-types+ , path , relude , rio , shake+ , shake-plus , shakebook , slick , split , text-time+ , within+ , zipper-extra default-language: Haskell2010 test-suite shakebook-test@@ -102,22 +110,26 @@ aeson , base >=4.7 && <5 , comonad- , comonad-extras , doctemplates , extra , feed , free , lens , lens-aeson+ , mustache , pandoc , pandoc-types+ , path , relude , rio , shake+ , shake-plus , shakebook , slick , split , tasty , tasty-golden , text-time+ , within+ , zipper-extra default-language: Haskell2010
src/Shakebook/Conventions.hs view
@@ -51,7 +51,7 @@ import Control.Comonad.Cofree import Control.Comonad.Store-import Control.Comonad.Store.Zipper+import Control.Comonad.Zipper.Extra import Control.Lens hiding ((:<)) import Control.Monad.Extra import Data.Aeson as A@@ -66,7 +66,6 @@ import qualified RIO.Vector as V import Shakebook.Aeson import Shakebook.Data-import Shakebook.Zipper import Text.Pandoc.Highlighting @@ -230,10 +229,11 @@ . withPosts (extract xs) $ Object mempty -genIndexPageData :: [Value]+genIndexPageData :: MonadThrow m+ => [Value] -> Text -> (Text -> Text) -> Int- -> Maybe (Zipper [] Value)-genIndexPageData xs g h n = extend (genPageData g h) <$> paginate n xs+ -> m (Zipper [] Value)+genIndexPageData xs g h n = extend (genPageData g h) <$> paginate' n xs
src/Shakebook/Data.hs view
@@ -1,27 +1,54 @@+{-# LANGUAGE TemplateHaskell #-} module Shakebook.Data where import Control.Comonad.Cofree import Control.Comonad.Store+import Control.Comonad.Zipper.Extra import Control.Lens hiding ((:<)) import Control.Monad.Extra import Data.Aeson as A import Data.Aeson.Lens-import Development.Shake as S-import Development.Shake.FilePath+import Development.Shake.Plus+import qualified Development.Shake.FilePath+import Path as P import RIO hiding (Lens', lens, view)-import RIO.List-import RIO.Partial import qualified RIO.Text as T import Shakebook.Aeson-import Slick import Slick.Pandoc import Text.Pandoc.Options+import Within +needLocalOut :: (MonadAction m, MonadReader r m, HasLocalOut r) => [Path Rel File] -> m ()+needLocalOut ys = view localOutL >>= \r -> needIn r ys++(%->) :: (MonadReader r m, MonadRules m, HasLocalOut r) => FilePattern -> (Within Rel File -> RAction r ()) -> m ()+(%->) pat f = view localOutL >>= \o -> (toFilePath o Development.Shake.FilePath.</> pat) %> \x -> (x `asWithin` o) >>= f++class HasLocalOut r where+ localOutL :: Lens' r (Path Rel Dir)++class HasLocalSrc r where+ localSrcL :: Lens' r (Path Rel Dir)++newtype PathDisplay a t = PathDisplay (Path a t)++instance Display (PathDisplay a t) where+ display (PathDisplay f) = displayBytesUtf8 . fromString . toFilePath $ f++newtype WithinDisplay a t = WithinDisplay (Within a t)++instance Display (WithinDisplay a t) where+ display (WithinDisplay (Within (x,y))) = display (PathDisplay x) <> "[" <> display (PathDisplay y) <> "]"++instance Display [WithinDisplay a t] where+ display [] = ""+ display (x : xs) = display x <> " : " <> display xs+ type ToC = Cofree [] String data SbConfig = SbConfig- { sbSrcDir :: FilePath- , sbOutDir :: FilePath+ { sbSrcDir :: Path Rel Dir+ , sbOutDir :: Path Rel Dir , sbBaseUrl :: Text , sbMdRead :: ReaderOptions , sbHTWrite :: WriterOptions@@ -32,48 +59,20 @@ class HasSbConfig a where sbConfigL :: Lens' a SbConfig -newtype Shakebook r a = Shakebook ( ReaderT r Rules a )- deriving (Functor, Applicative, Monad, MonadReader r, MonadIO)--newtype ShakebookA r a = ShakebookA ( ReaderT r Action a )- deriving (Functor, Applicative, Monad, MonadReader r, MonadIO)--runShakebook :: r -> Shakebook r a -> Rules a-runShakebook c (Shakebook f) = runReaderT f c--runShakebookA :: r -> ShakebookA r a -> Action a-runShakebookA c (ShakebookA f) = runReaderT f c--class MonadAction m where- liftAction :: Action a -> m a--class MonadRules m where- liftRules :: Rules a -> m a--instance MonadAction (ShakebookA r) where- liftAction = ShakebookA . lift--instance MonadRules (Shakebook r) where- liftRules = Shakebook . lift- data ShakebookEnv = ShakebookEnv { logFunc :: LogFunc , sbConfig :: SbConfig } +instance HasLocalOut ShakebookEnv where+ localOutL = lens (sbOutDir . sbConfig) undefined+ instance HasSbConfig ShakebookEnv where sbConfigL = lens sbConfig undefined instance HasLogFunc ShakebookEnv where logFuncL = lens logFunc undefined -type MonadShakebook r m = (MonadReader r m, HasSbConfig r, HasLogFunc r, MonadIO m)-type MonadShakebookAction r m = (MonadShakebook r m, MonadAction m)-type MonadShakebookRules r m = (MonadShakebook r m, MonadRules m)---- -- | View the "srcPath" field of a JSON Value. viewSrcPath :: Value -> Text viewSrcPath = view (key "srcPath" . _String)@@ -106,70 +105,57 @@ enrichUrl :: (Text -> Text) -> Value -> Value enrichUrl f v = withUrl (f (viewSrcPath v)) v --- | Filepath/URL calculators - these work but don't try to do the wrong thing or it will explode.-typicalFullOutToSrcPath :: MonadShakebook r m => m (String -> String)-typicalFullOutToSrcPath = view sbConfigL >>= \SbConfig{..} -> pure $- drop 1 . fromJust . stripPrefix sbOutDir--typicalFullOutToFullSrcPath :: MonadShakebook r m => m (String -> String)-typicalFullOutToFullSrcPath = view sbConfigL >>= \SbConfig{..} -> - liftA2 (.) (pure (sbSrcDir </>)) typicalFullOutToSrcPath+leadingSlash :: Path Abs Dir+leadingSlash = $(mkAbsDir "/") -typicalFullOutHTMLToMdSrcPath :: MonadShakebook r m => m (String -> String)-typicalFullOutHTMLToMdSrcPath = liftA2 (.) (pure (-<.> "md")) typicalFullOutToSrcPath+withHtmlExtension :: MonadThrow m => Path Rel File -> m (Path Rel File)+withHtmlExtension = replaceExtension ".html" -typicalMdSrcPathToHTMLFullOut :: MonadShakebook r m => m (String -> String)-typicalMdSrcPathToHTMLFullOut = view sbConfigL >>= \SbConfig{..} -> pure $- (-<.> "html") . (sbOutDir </>) . drop 1 . fromJust . stripPrefix sbSrcDir+withMarkdownExtension :: MonadThrow m => Path Rel File -> m (Path Rel File)+withMarkdownExtension = replaceExtension ".md" -typicalSrcPathToUrl :: Text -> Text-typicalSrcPathToUrl = ("/" <>) . T.pack . (-<.> "html") . T.unpack+generateSupposedUrl :: MonadThrow m => Path Rel File -> m (Path Abs File)+generateSupposedUrl srcPath = (leadingSlash </>) <$> withHtmlExtension srcPath -enrichTypicalUrl :: Value -> Value-enrichTypicalUrl v = withUrl (typicalSrcPathToUrl . viewSrcPath $ v) v+enrichSupposedUrl :: (MonadReader r m, HasSbConfig r, MonadThrow m) => Value -> m Value+enrichSupposedUrl v = view sbConfigL >>= \SbConfig{..} -> do+ x <- parseRelFile $ T.unpack $ viewSrcPath v+ y <- generateSupposedUrl x+ return $ withUrl (T.pack . toFilePath $ y) v {-| Get a JSON Value of Markdown Data with markdown body as "contents" field and the srcPath as "srcPath" field. -}-readMarkdownFile' :: MonadShakebookAction r m => String -> m Value-readMarkdownFile' srcPath = view sbConfigL >>= \SbConfig{..} -> do- logInfo $ displayShow $ "Reading source: " <> srcPath- liftAction $ do- docContent <- readFile' (sbSrcDir </> srcPath)- docData <- markdownToHTMLWithOpts sbMdRead sbHTWrite . T.pack $ docContent- return $ withSrcPath (T.pack srcPath) docData--loadIfExists :: (FilePath -> Action Value) -> FilePath -> Action Value-loadIfExists f src = ifM (S.doesFileExist src) (f src) (return (Object mempty))+readMarkdownFile' :: (MonadReader r m, HasSbConfig r, MonadAction m)+ => Within Rel File+ -> m Value+readMarkdownFile' srcPath = view sbConfigL >>= \SbConfig{..} -> liftAction $ do+ docContent <- readFile' (fromWithin srcPath)+ docData <- markdownToHTMLWithOpts sbMdRead sbHTWrite docContent+ supposedUrl <- liftIO $ (leadingSlash </>) <$> withHtmlExtension (whatLiesWithin srcPath)+ return $ withSrcPath (T.pack . toFilePath $ whatLiesWithin srcPath)+ . withUrl (T.pack . toFilePath $ supposedUrl) $ docData -getMarkdown :: MonadShakebookAction r m => [FilePattern] -> m [Value]-getMarkdown pat = view sbConfigL >>= \SbConfig{..} ->- liftAction (getDirectoryFiles sbSrcDir pat) >>= mapM readMarkdownFile'+data PaginationException = EmptyContentsError+ deriving (Show, Eq, Typeable) -{-| - Build a single page straight from a template, a loaded Value, and a pure enrichment.--}-genBuildPageAction :: (MonadShakebookAction r m)- => FilePath -- ^ The HTML template- -> (FilePath -> m Value) -- ^ How to get from FilePath to Value, can use Actions.- -> (Value -> Value) -- ^ Additional modifiers for the value.- -> FilePath -- ^ The out filepath- -> m Value-genBuildPageAction template getData withData out = view sbConfigL >>= \SbConfig{..} -> do- logInfo $ displayShow $ "Generating page with fullpath " <> out- pageT <- liftAction $ compileTemplate' (sbSrcDir </> template)- dataT <- withData . enrichTypicalUrl <$> getData out- logDebug $ displayShow dataT- writeFile' out . T.unpack $ substitute pageT dataT- return dataT+instance Exception PaginationException where+ displayException EmptyContentsError = "Can not create a Zipper of length zero." -traverseToSnd :: Functor f => (a -> f b) -> a -> f (a, b)-traverseToSnd f a = (a,) <$> f a+paginate' :: MonadThrow m => Int -> [a] -> m (Zipper [] [a])+paginate' n xs = case paginate n xs of+ Just x -> return x+ Nothing -> throwM EmptyContentsError lower :: Cofree [] Value -> [Value] lower (_ :< xs) = extract <$> xs +type MonadShakebook r m = (MonadReader r m, HasSbConfig r, HasLogFunc r, MonadIO m, MonadThrow m, HasLocalOut r)+type MonadShakebookAction r m = (MonadShakebook r m, MonadAction m)+type MonadShakebookRules r m = (MonadShakebook r m, MonadRules m)++ {-| Multi-markdown loader. Allows you to load a filepattern of markdown as a list of JSON values ready to pass to an HTML template. You will probably want to add additional@@ -180,16 +166,14 @@ -> (Value -> b) -- ^ A value to sortOn e.g (Down . viewPostTime) -> (Value -> Bool) -- ^ A filtering predicate e.g (elem tag . viewTags) -> (Value -> Value) -- ^ An initial enrichment. This is pure so can only be data derived from the initial markdown.- -> m [(FilePath, Value)] -- ^ A list of Values indexed by their srcPath.-loadSortFilterEnrich pat s f e = view sbConfigL >>= \SbConfig {..} -> do- allPosts <- liftAction $ getDirectoryFiles sbSrcDir $ map (-<.> ".md") pat- readPosts <- sequence $ traverseToSnd readMarkdownFile' <$> allPosts- return $ fmap (second e) $ sortOn (s . snd) $ filter (f . snd) readPosts+ -> m [(Within Rel File, Value)] -- ^ A list of Values indexed by their srcPath.+loadSortFilterEnrich pat s f e = view sbConfigL >>= \SbConfig {..} ->+ loadSortFilterApplyW readMarkdownFile' sbSrcDir pat s f e -- | The same as `loadSortFilterEnrich` but without filtering. loadSortEnrich :: (MonadShakebookAction r m, Ord b) => [FilePattern] -- ^ A Shake filepattern to load. -> (Value -> b) -- ^ A value to sortOn e.g (Down . viewPostTime). -> (Value -> Value) -- ^ An initial pure enrichment.- -> m [(String, Value)] -- ^ A list of Values index by their srcPath.+ -> m [(Within Rel File, Value)] -- ^ A list of Values index by their srcPath. loadSortEnrich pat s = loadSortFilterEnrich pat s (const True)
src/Shakebook/Defaults.hs view
@@ -1,18 +1,17 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TemplateHaskell #-} module Shakebook.Defaults where import Control.Comonad import Control.Comonad.Cofree import Control.Comonad.Store.Class-import Control.Comonad.Store.Zipper+import Control.Comonad.Zipper.Extra import Control.Monad.Extra import Data.Aeson as A import Data.List.Split import Data.Text.Time-import Development.Shake as S-import Development.Shake.Classes-import Development.Shake.FilePath+import Development.Shake.Plus+import qualified Development.Shake.FilePath as S import RIO import qualified RIO.ByteString.Lazy as LBS import RIO.List@@ -21,11 +20,11 @@ import RIO.Partial import qualified RIO.Text as T import RIO.Time+import Path as P import Shakebook.Aeson import Shakebook.Conventions import Shakebook.Data-import Shakebook.Rules-import Shakebook.Zipper+import Shakebook.Mustache import Text.DocTemplates import Text.Pandoc.Class import Text.Pandoc.Definition@@ -35,9 +34,10 @@ import Text.Pandoc.Templates import Text.Pandoc.Walk import Text.Pandoc.Writers+import Within -defaultMonthURLFormat :: UTCTime -> String-defaultMonthURLFormat = formatTime defaultTimeLocale "%Y-%m"+defaultMonthUrlFormat :: UTCTime -> String+defaultMonthUrlFormat = formatTime defaultTimeLocale "%Y-%m" defaultPrettyMonthFormat :: UTCTime -> String defaultPrettyMonthFormat = formatTime defaultTimeLocale "%B, %Y"@@ -45,14 +45,22 @@ defaultPrettyTimeFormat :: UTCTime -> String defaultPrettyTimeFormat = formatTime defaultTimeLocale "%A, %B %d, %Y" -defaultMonthIndexUrlFormat :: UTCTime -> String-defaultMonthIndexUrlFormat t = "/posts/months" </> defaultMonthURLFormat t+defaultIndexFileFragment :: Path Rel File+defaultIndexFileFragment = $(mkRelFile "index.html") +defaultMonthDirFragment :: MonadThrow m => UTCTime -> m (Path Rel Dir)+defaultMonthDirFragment t = do+ k <- parseRelDir $ defaultMonthUrlFormat t+ return $ $(mkRelDir "posts/months") </> k++defaultMonthUrlFragment :: UTCTime -> Text+defaultMonthUrlFragment t = T.pack $ "/posts/months/" <> defaultMonthUrlFormat t+ defaultEnrichPost :: Value -> Value defaultEnrichPost = enrichTeaser "<!--more-->" . enrichTagLinks ("/posts/tags/" <>) . enrichPrettyDate defaultPrettyTimeFormat- . enrichTypicalUrl+-- . enrichTypicalUrl defaultMarkdownReaderOptions :: ReaderOptions defaultMarkdownReaderOptions = def { readerExtensions = pandocExtensions }@@ -68,9 +76,18 @@ , ("linkcolor",SimpleVal "blue")] } +defaultSbSrcDir :: Path Rel Dir+defaultSbSrcDir = $(mkRelDir "site")++defaultSbOutDir :: Path Rel Dir+defaultSbOutDir = $(mkRelDir "public")++defaultPostsPerPage :: Int+defaultPostsPerPage = 5+ defaultSbConfig :: Text -- ^ BaseURL -> SbConfig-defaultSbConfig x = SbConfig "site" "public" x defaultMarkdownReaderOptions defaultHtml5WriterOptions 5+defaultSbConfig x = SbConfig defaultSbSrcDir defaultSbOutDir x defaultMarkdownReaderOptions defaultHtml5WriterOptions defaultPostsPerPage affixBlogNavbar :: MonadShakebookAction r m => [FilePattern]@@ -95,24 +112,22 @@ -defaultDocsPatterns :: MonadShakebookRules r m+defaultDocsPatterns :: (MonadShakebookRules r m) => Cofree [] FilePath -- Rosetree Table of Contents. -> FilePath -> (Value -> Value) -- Extra data modifiers. -> m ()-defaultDocsPatterns toc tmpl withData = ask >>= \r -> view sbConfigL >>= \SbConfig {..} -> do- let e = enrichTypicalUrl- m <- typicalFullOutHTMLToMdSrcPath- liftRules $ cofreeRuleGen toc ((sbOutDir </>) . (-<.> ".html")) (- \xs -> \out -> runShakebookA r $ do- ys <- mapM readMarkdownFile' toc- zs <- mapM readMarkdownFile' xs- void $ genBuildPageAction tmpl- (readMarkdownFile' . m)- (withData- . withJSON (genTocNavbarData (e <$> ys))- . withSubsections (lower (e <$> zs)))- out)+defaultDocsPatterns toc tmpl withData = view sbConfigL >>= \SbConfig{..} -> do+ tmpl' <- parseRelFile tmpl+ o <- view localOutL+ toc' <- mapM (parseRelFile >=> pure . (`within` o) >=> mapWithinT withHtmlExtension) toc+ let e = blinkAndMapT sbSrcDir withMarkdownExtension >=> readMarkdownFile' >=> enrichSupposedUrl+ void . sequence . flip extend toc' $ \xs -> (toFilePath . whatLiesWithin $ extract xs) %-> \out -> do+ ys <- mapM e toc'+ zs <- mapM e xs+ v <- e out+ let v' = withData . withJSON (genTocNavbarData ys) . withSubsections (lower (zs)) $ v+ buildPageActionWithin (tmpl' `within` sbSrcDir) v' out defaultPostIndexData :: MonadShakebookAction r m => [FilePattern]@@ -123,25 +138,29 @@ -> m (Zipper [] Value) -- A pager of index pages. defaultPostIndexData pat f t l a = view sbConfigL >>= \SbConfig {..} -> do xs <- loadSortFilterEnrich pat (Down . viewPostTime) (f a) defaultEnrichPost- let ys = genIndexPageData (snd <$> xs) (t a) (l a) sbPPP- return $ fromJust $ ys+ ys <- genIndexPageData (snd <$> xs) (t a) (l a) sbPPP+ return ys -defaultPagerPattern :: MonadShakebookRules r m+defaultPagerPattern :: (MonadShakebookRules r m) => FilePattern -> FilePath -> (FilePattern -> Int) -- ^ How to extract a page number from the Filepattern. -> (FilePattern -> a) -- ^ How to extract an id from the FilePattern- -> (a -> ShakebookA r (Zipper [] Value))- -> (Zipper [] Value -> ShakebookA r (Zipper [] Value))+ -> (a -> RAction r (Zipper [] Value))+ -> (Zipper [] Value -> RAction r (Zipper [] Value)) -> m ()-defaultPagerPattern fp tmpl f g h w = ask >>= \r -> view sbConfigL >>= \SbConfig{..} -> liftRules $- comonadStoreRuleGen (sbOutDir </> fp) (f . drop 1 . fromJust . stripPrefix sbOutDir) (g . drop 1 . fromJust . stripPrefix sbOutDir) (runShakebookA r . (w <=< h))- (\a -> void <$> runShakebookA r . genBuildPageAction tmpl (const $ return a) id)+defaultPagerPattern fp tmpl f g h w = view sbConfigL >>= \SbConfig{..} -> do+ tmpl' <- parseRelFile tmpl+ fp %-> \x -> do+ let x' = toFilePath $ whatLiesWithin x+ xs <- (w <=< h) $ g (x')+ let b = extract (seek (f x') xs)+ buildPageActionWithin (tmpl' `within` sbSrcDir) b x defaultPostIndexPatterns :: MonadShakebookRules r m => [FilePattern] -> FilePath- -> (Zipper [] Value -> ShakebookA r (Zipper [] Value)) -- ^ Pager extension.+ -> (Zipper [] Value -> RAction r (Zipper [] Value)) -- ^ Pager extension. -> m () defaultPostIndexPatterns pat tmpl extData = do defaultPagerPattern "posts/index.html" tmpl@@ -162,7 +181,7 @@ defaultTagIndexPatterns :: MonadShakebookRules r m => [FilePattern] -> FilePath- -> (Zipper [] Value -> ShakebookA r (Zipper [] Value)) -- ^ Pager extension.+ -> (Zipper [] Value -> RAction r (Zipper [] Value)) -- ^ Pager extension. -> m () defaultTagIndexPatterns pat tmpl extData = do defaultPagerPattern ("posts/tags/*/index.html") tmpl@@ -183,7 +202,7 @@ defaultMonthIndexPatterns :: MonadShakebookRules r m => [FilePattern] -> FilePath- -> (Zipper [] Value -> ShakebookA r (Zipper [] Value)) -- ^ Pager extension.+ -> (Zipper [] Value -> RAction r (Zipper [] Value)) -- ^ Pager extension. -> m () defaultMonthIndexPatterns pat tmpl extData = do defaultPagerPattern "posts/months/*/index.html" tmpl@@ -192,7 +211,7 @@ (defaultPostIndexData pat (\x y -> sameMonth x (viewPostTime y)) (("Posts from " <>) . T.pack . defaultPrettyMonthFormat)- (\x y -> ("/posts/months/" <> T.pack (defaultMonthURLFormat x) <> "/pages" <> y)))+ (\x y -> ("/posts/months/" <> T.pack (defaultMonthUrlFormat x) <> "/pages" <> y))) extData defaultPagerPattern "posts/months/*/pages/*/index.html" tmpl ((+ (-1)) . read . (!! 4) . splitOn "/")@@ -200,7 +219,7 @@ (defaultPostIndexData pat (\x y -> sameMonth x (viewPostTime y)) (("Posts from " <>) . T.pack . defaultPrettyMonthFormat)- (\x y -> ("/posts/months/" <> T.pack (defaultMonthURLFormat x) <> "/pages" <> y)))+ (\x y -> ("/posts/months/" <> T.pack (defaultMonthUrlFormat x) <> "/pages" <> y))) extData {-|@@ -209,31 +228,35 @@ defaultPostsPatterns :: MonadShakebookRules r m => FilePattern -> FilePath- -> (Value -> ShakebookA r Value) -- ^ A post loader function.- -> (Zipper [] Value -> ShakebookA r (Zipper [] Value)) -- ^ A transformation on the entire post zipper.+ -> (Value -> RAction r Value) -- ^ A post loader function.+ -> (Zipper [] Value -> RAction r (Zipper [] Value)) -- ^ A transformation on the entire post zipper. -> m ()-defaultPostsPatterns pat tmpl e extData = ask >>= \r -> view sbConfigL >>= \SbConfig {..} ->- liftRules $ sbOutDir </> pat %> \out -> do- sortedPosts <- runShakebookA r $ do- xs <- loadSortEnrich [pat] (Down . viewPostTime) defaultEnrichPost- mapM (\(s,x) -> e x >>= \e' -> return (s, e')) xs- let i = (-<.> ".md") . drop 1 . fromJust . stripPrefix sbOutDir $ out- let k = fromJust $ elemIndex i (fst <$> sortedPosts)- let z = fromJust $ seek k <$> zipper (snd <$> sortedPosts)- void $ runShakebookA r $ genBuildPageAction tmpl- (const $ extract <$> extData z)- id out+defaultPostsPatterns pat tmpl e extData = view sbConfigL >>= \SbConfig {..} ->+ pat %-> \out -> do+ logInfo $ display $ "Caught pattern: " <> display (WithinDisplay out)+ tmpl' <- parseRelFile tmpl+ logInfo $ display $ "Using template " <> display (PathDisplay tmpl')+ let pat' = pat S.-<.> ".md"+ xs <- loadSortEnrich [pat'] (Down . viewPostTime) defaultEnrichPost+ xs' <- mapM (\(s,x) -> e x >>= \e' -> return (s, e')) xs+ i <- blinkAndMapT sbSrcDir withMarkdownExtension out+ logInfo $ display $ WithinDisplay i+ logInfo $ display $ WithinDisplay . fst <$> xs'+ let k = fromJust $ elemIndex i (fst <$> xs')+ let z = fromJust $ seek k <$> zipper (snd <$> xs')+ z' <- extData z+ buildPageActionWithin (tmpl' `within` sbSrcDir) (extract z') out makePDFLaTeX :: Pandoc -> PandocIO (Either LBS.ByteString LBS.ByteString) makePDFLaTeX p = do t <- compileDefaultTemplate "latex" makePDF "pdflatex" [] writeLaTeX defaultLatexWriterOptions { writerTemplate = Just t } p -handleImages :: (Text -> Text) -> Inline -> Inline-handleImages f (Image attr ins (src,txt)) =+handleImages :: Text -> (Text -> Text) -> Inline -> Inline+handleImages prefix f (Image attr ins (src,txt)) = if T.takeEnd 4 src == ".mp4" then Str (f src)- else Image attr ins ("public/" <> src, txt)-handleImages _ x = x+ else Image attr ins (prefix <> "/" <> src, txt)+handleImages _ _ x = x handleHeaders :: Int -> Block -> Block handleHeaders i (Header a as xs) = Header (max 1 (a + i)) as xs@@ -243,14 +266,14 @@ pushHeaders i (x :< xs) = walk (handleHeaders i) x :< map (pushHeaders (i+1)) xs -- | Build a PDF from a Cofree table of contents.-buildPDF :: MonadShakebookAction r m => Cofree [] String -> String -> FilePath -> m ()-buildPDF toc meta out = view sbConfigL >>= \SbConfig {..} -> liftAction $ do- y <- mapM readFile' ((sbSrcDir </>) <$> toc)- m <- readFile' $ sbSrcDir </> meta+buildPDF :: (MonadShakebookAction r m, MonadFail m) => Cofree [] String -> Path Rel File -> FilePath -> m ()+buildPDF toc meta out = view sbConfigL >>= \SbConfig {..} -> do+ y <- mapM (readFileIn' sbSrcDir <=< parseRelFile) toc+ m <- readFileIn' sbSrcDir meta Right f <- liftIO . runIOorExplode $ do- k <- mapM (readMarkdown sbMdRead . T.pack) y- a <- readMarkdown sbMdRead . T.pack $ m- let z = walk (handleImages (\x -> "[Video available at " <> sbBaseUrl <> x <> "]")) $ foldr (<>) a $ pushHeaders (-1) k+ k <- mapM (readMarkdown sbMdRead ) y+ a <- readMarkdown sbMdRead $ m+ let z = walk (handleImages (T.pack $ toFilePath sbOutDir) (\x -> "[Video available at " <> sbBaseUrl <> x <> "]")) $ foldr (<>) a $ pushHeaders (-1) k makePDFLaTeX z LBS.writeFile out f @@ -259,72 +282,68 @@ called singlePagePattern, as there's no hardcoded strings here, but it would need to run entirely within the monad to translate filepaths. -}-defaultSinglePagePattern :: MonadShakebookRules r m+defaultSinglePagePattern :: (MonadRules m, MonadReader r m, HasSbConfig r, HasLocalOut r) => FilePath -- ^ The output filename e.g "index.html". -> FilePath -- ^ A tmpl file.- -> (Value -> ShakebookA r Value) -- ^ Last minute enrichment.+ -> (Value -> RAction r Value) -- ^ Last minute enrichment. -> m ()-defaultSinglePagePattern out tmpl withDataM = ask >>= \r -> view sbConfigL >>= \SbConfig {..} -> do- m <- typicalFullOutHTMLToMdSrcPath- liftRules $ sbOutDir </> out %> void . runShakebookA r . genBuildPageAction- tmpl- (\fp -> do- x <- readMarkdownFile' . m $ fp- withDataM $ x)- id+defaultSinglePagePattern out tmpl withDataM = view sbConfigL >>= \SbConfig {..} -> do+ out %-> \x -> do+ tmpl' <- parseRelFile tmpl+ x' <- blinkAndMapT sbSrcDir withMarkdownExtension $ x+ v <- withDataM =<< readMarkdownFile' x'+ buildPageActionWithin (tmpl' `within` sbSrcDir) v x {-| Default statics patterns. Takes a list of filepatterns and adds a rule that copies everything verbatim -} defaultStaticsPatterns :: MonadShakebookRules r m => [FilePattern] -> m ()-defaultStaticsPatterns xs = view sbConfigL >>= \SbConfig {..} -> do- f <- typicalFullOutToFullSrcPath- liftRules $ mconcat $ map (\x -> sbOutDir </> x %> \y -> copyFileChanged (f y) y) xs+defaultStaticsPatterns xs = view sbConfigL >>= \SbConfig {..} -> do+ foldr (>>) (return ()) $ flip map xs $ flip (%->) $ \y -> do+ let y' = blinkWithin sbSrcDir y+ copyFileChanged (fromWithin y') (fromWithin y) -- | Default "shake clean" phony, cleans your output directory. defaultCleanPhony :: MonadShakebookRules r m => m ()-defaultCleanPhony = view sbConfigL >>= \SbConfig {..} -> liftRules $+defaultCleanPhony = view sbConfigL >>= \SbConfig {..} -> phony "clean" $ do- putInfo $ "Cleaning files in " ++ sbOutDir+ logInfo $ "Cleaning files in " <> display (PathDisplay sbOutDir) removeFilesAfter sbOutDir ["//*"] defaultSinglePagePhony :: MonadShakebookRules r m => String -> FilePath -> m ()-defaultSinglePagePhony x y = view sbConfigL >>= \SbConfig {..} -> liftRules $ - phony x $ need [sbOutDir </> y]+defaultSinglePagePhony x y = phony x $ parseRelFile y >>= needLocalOut . pure {-| Default "shake statics" phony rule. automatically runs need on "\<out\>\/thing\/\*" for every thing found in "images\/", "css\/", "js\/" and "webfonts\/" -}-defaultStaticsPhony :: MonadShakebookRules r m => m ()-defaultStaticsPhony = view sbConfigL >>= \SbConfig {..} -> liftRules $- phony "statics" $ do- fp <- getDirectoryFiles sbSrcDir ["images//*", "css//*", "js//*", "webfonts//*"]- need $ [sbOutDir </> x | x <- fp]+defaultStaticsPhony :: MonadShakebookRules r m => [FilePattern] -> m ()+defaultStaticsPhony pattern = view sbConfigL >>= \SbConfig{..} -> + phony "statics" $ + getDirectoryFiles sbSrcDir pattern >>= needIn sbOutDir {-| Default "shake posts" phony rule. takes a [FilePattern] pointing to the posts and and calls need on "\<out\>\/posts\/\<filename\>.html" for each markdown post found. -} defaultPostsPhony :: MonadShakebookRules r m => [FilePattern] -> m ()-defaultPostsPhony pattern = view sbConfigL >>= \SbConfig {..} -> liftRules $- phony "posts" $ do- fp <- getDirectoryFiles sbSrcDir pattern- need [sbOutDir </> x -<.> ".html" | x <- fp]+defaultPostsPhony pattern = view sbConfigL >>= \SbConfig{..} -> + phony "posts" $ + getDirectoryFilesWithin sbSrcDir pattern >>= mapM (blinkAndMapT sbOutDir withHtmlExtension) >>= needWithin + {-| Default "shake posts-index" phony rule. Takes a [FilePattern] of posts to discover and calls need on "\<out\>\/posts\/index.html" and "\<out\>\/posts\/pages\/\<n\>\/index.html" for each page required. -} defaultPostIndexPhony :: MonadShakebookRules r m => [FilePattern] -> m ()-defaultPostIndexPhony pattern = ask >>= \r -> view sbConfigL >>= \SbConfig {..} -> liftRules $+defaultPostIndexPhony pattern = view sbConfigL >>= \SbConfig{..} -> phony "posts-index" $ do- fp <- runShakebookA r $ getMarkdown pattern- need [sbOutDir </> "posts/index.html"]- need [sbOutDir </> "posts/pages/" ++ show x ++ "/index.html"- | x <- [1..size (fromJust $ paginate sbPPP fp)]]+ fp <- getDirectoryFilesWithin sbSrcDir pattern >>= mapM readMarkdownFile'+ needIn sbOutDir [dirPosts </> fileIndexHTML]+ paginate' sbPPP fp >>= defaultPagePaths dirPosts >>= needIn sbOutDir {-| Default "shake tag-index" phony rule. Takes a [FilePattern] of posts to@@ -333,38 +352,56 @@ each page required per tag filter. -} defaultTagIndexPhony :: MonadShakebookRules r m => [FilePattern] -> m ()-defaultTagIndexPhony pattern = ask >>= \r -> view sbConfigL >>= \SbConfig {..} -> liftRules $- phony "tag-index" $ do- fp <- runShakebookA r $ getMarkdown pattern- let tags = viewAllPostTags fp- need [sbOutDir </> "posts/tags" </> T.unpack x </> "index.html" | x <- tags]- need [sbOutDir </> "posts/tags" </> T.unpack x </> "pages" </> show p </> "index.html"- | x <- tags- , p <- [1..size (fromJust $ paginate sbPPP $ tagFilterPosts x fp)]- ]+defaultTagIndexPhony pattern = view sbConfigL >>= \SbConfig{..} ->+ phony "tag-index" $ do+ fp <- getDirectoryFilesWithin sbSrcDir pattern >>= mapM readMarkdownFile'+ forM_ (viewAllPostTags fp) $ \t -> do+ u <- parseRelDir $ T.unpack t+ needIn sbOutDir [dirPosts </> dirTags </> u </> fileIndexHTML]+ paginate' sbPPP (tagFilterPosts t fp)+ >>= defaultPagePaths (dirPosts </> dirTags </> u)+ >>= needIn sbOutDir +defaultPagePaths :: MonadThrow m => Path Rel Dir -> Zipper [] [a] -> m [Path Rel File]+defaultPagePaths a xs = forM [1..size xs] $ parseRelDir . show >=> \p -> return $ a </> dirPages </> p </> fileIndexHTML++fileIndexHTML :: Path Rel File+fileIndexHTML = $(mkRelFile "index.html")++dirPosts :: Path Rel Dir+dirPosts = $(mkRelDir "posts")++dirMonths :: Path Rel Dir+dirMonths = $(mkRelDir "months")++dirPages :: Path Rel Dir+dirPages = $(mkRelDir "pages")++dirTags :: Path Rel Dir+dirTags = $(mkRelDir "tags")+ {-| Default "shake month-index" phony rule. Takes a [FilePattern] of posts to discover and calls need on "\<out\>\/posts\/months\/\<yyyy-md\>\/index.html" and "\<out\>\/posts\/months\/\<yyyy-md\>\/pages\/\<n\>\/index.html" for each month discovered that contains a post and for each page required per month filter. -}-defaultMonthIndexPhony :: MonadShakebookRules r m => [FilePattern] -> m ()-defaultMonthIndexPhony pattern = ask >>= \r -> view sbConfigL >>= \SbConfig {..} -> liftRules $- phony "month-index" $ do- fp <- runShakebookA r $ getMarkdown pattern- let times = viewAllPostTimes fp- need [sbOutDir </> "posts/months" </> defaultMonthURLFormat t </> "index.html" | t <- times]- need [sbOutDir </> "posts/months" </> defaultMonthURLFormat t </> "pages" </> show p </> "index.html"- | t <- times- , p <- [1..length (fromJust $ paginate sbPPP $ monthFilterPosts t fp)]- ]+defaultMonthIndexPhony :: (MonadRules m, MonadReader r m, HasSbConfig r, HasLocalOut r) => [FilePattern] -> m ()+defaultMonthIndexPhony pattern = phony "month-index" $ do+ SbConfig{..} <- view sbConfigL+ fp <- getDirectoryFilesWithin sbSrcDir pattern >>= mapM readMarkdownFile'+ forM_ (viewAllPostTimes fp) $ \t -> do+ u <- parseRelDir $ defaultMonthUrlFormat t+ needLocalOut [dirPosts </> dirMonths </> u </> fileIndexHTML]+ paginate' sbPPP (monthFilterPosts t fp)+ >>= defaultPagePaths (dirPosts </> dirMonths </> u)+ >>= needLocalOut -- | Default "shake docs" phony rule, takes a Cofree [] String as a table of contents. defaultDocsPhony :: MonadShakebookRules r m- => Cofree [] String+ => Cofree [] String -> m ()-defaultDocsPhony toc = view sbConfigL >>= \SbConfig {..} -> liftRules $+defaultDocsPhony toc = view sbConfigL >>= \SbConfig{..} -> phony "docs" $ do- let xs = (foldr ((<>) . pure) [] toc)- need $ [ (sbOutDir </>) . (-<.> ".html") $ x | x <- xs]+ let xs = foldr ((<>) . pure) [] $ toc+ pure xs >>= mapM (parseRelFile >=> withHtmlExtension) >>= needIn sbOutDir
+ src/Shakebook/Mustache.hs view
@@ -0,0 +1,43 @@+{-|+Module : Shakebook.Mustache+Description : Slick mustache utilities re-exported to use `Path`+Copyright : (c) Daniel Firth 2020+License : MIT+-}++module Shakebook.Mustache (+ Text.Mustache.Template+, buildPageAction+, buildPageActionWithin+, compileTemplate'+) where++import Data.Aeson+import Path+import RIO+import qualified Slick.Mustache+import Development.Shake.Plus+import Text.Mustache+import Within++compileTemplate' :: MonadAction m => Path Rel File -> m Template+compileTemplate' = liftAction . Slick.Mustache.compileTemplate' . toFilePath++{-| + Build a single page straight from a template.+-}+buildPageAction :: MonadAction m+ => Path Rel File -- ^ The HTML templatate.+ -> Value -- ^ A JSON value.+ -> Path Rel File -- ^ The out filepath.+ -> m ()+buildPageAction template value out = do+ pageT <- compileTemplate' template+ writeFile' out $ substitute pageT value++buildPageActionWithin :: MonadAction m+ => Within Rel File+ -> Value+ -> Within Rel File+ -> m ()+buildPageActionWithin template value out = buildPageAction (fromWithin template) value (fromWithin out)
src/Shakebook/Rules.hs view
@@ -25,7 +25,7 @@ -} cofreeRuleGen :: (Traversable w, ComonadCofree f w) => w FilePath -- ^ A cofree comonad of FilePaths- -> (FilePath -> FilePath) -- ^ How to find the source for each out FilePath.+ -> (FilePath -> FilePath) -- ^ How to find the out path for each source FilePath. -> (w FilePath -> FilePath -> Action ()) -- ^ How to generate a write Action for the target of a comonad. This is extended over the whole comonad. -> Rules () cofreeRuleGen xs h k = do
− src/Shakebook/Zipper.hs
@@ -1,29 +0,0 @@-{-| Zipper utils that weren't in Control.Comonad.Store.Zipper -}--module Shakebook.Zipper (- paginate-, zipperNextMaybe-, zipperPreviousMaybe-, zipperWithin-) where--import Control.Comonad.Store-import Control.Comonad.Store.Zipper-import Data.List.Split-import RIO---- Turn a list into a zipper of chunks of length n-paginate :: Int -> [a] -> Maybe (Zipper [] [a])-paginate n = zipper . chunksOf n---- Return the peek of the next element if it exists.-zipperNextMaybe :: Zipper [] a -> Maybe a-zipperNextMaybe xs = if pos xs < size xs-1 then Just (peeks (+1) xs) else Nothing---- Return the peek of the previous element if it exists.-zipperPreviousMaybe :: Zipper [] a -> Maybe a-zipperPreviousMaybe xs = if pos xs > 0 then Just (peeks (+ (-1)) xs) else Nothing---- Return a list of elements within 'r' hops either side of the zipper target.-zipperWithin :: Int -> Zipper [] a -> [a]-zipperWithin r xs = (`peek` xs) <$> [(max 0 (pos xs - r)) .. (min (size xs -1) (pos xs + r))]
test/Spec.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE TemplateHaskell #-} import Control.Comonad.Cofree-import Control.Comonad.Store.Zipper+import Control.Comonad.Zipper.Extra import Data.Aeson import Data.List.Split-import Development.Shake+import Development.Shake.Plus+import Path import RIO import RIO.List import qualified RIO.Text as T@@ -14,11 +16,11 @@ import Test.Tasty.Golden import Text.Pandoc.Highlighting -srcDir :: String-srcDir = "test/site"+srcDir :: Path Rel Dir+srcDir = $(mkRelDir "test/site") -outDir :: String-outDir = "test/public"+outDir :: Path Rel Dir+outDir = $(mkRelDir "test/public") baseUrl :: Text baseUrl = "http://blanky.test"@@ -32,7 +34,7 @@ ] myBlogNavbar :: [Value] -> Value-myBlogNavbar = genBlogNavbarData "Blog" "/posts/" (T.pack . defaultPrettyMonthFormat) (T.pack . defaultMonthIndexUrlFormat)+myBlogNavbar = genBlogNavbarData "Blog" "/posts/" (T.pack . defaultPrettyMonthFormat) (defaultMonthUrlFragment) numRecentPosts :: Int numRecentPosts = 3@@ -58,7 +60,7 @@ (affixRecentPosts ["posts/*.md"] numRecentPosts defaultEnrichPost) defaultPostsPatterns "posts/*.html" "templates/post.html"- (affixBlogNavbar ["posts/*.md"] "Blog" "/posts/" (T.pack . defaultPrettyMonthFormat) (T.pack . defaultMonthIndexUrlFormat) defaultEnrichPost+ (affixBlogNavbar ["posts/*.md"] "Blog" "/posts/" (T.pack . defaultPrettyMonthFormat) (defaultMonthUrlFragment) defaultEnrichPost <=< affixRecentPosts ["posts/*.md"] numRecentPosts defaultEnrichPost . defaultEnrichPost . withHighlighting pygments) extendPostsZipper@@ -75,7 +77,7 @@ defaultMonthIndexPatterns ["posts/*.md"] "templates/post-list.html" (enrichPostIndexPage ["posts/*.md"]) defaultStaticsPatterns ["css//*", "images//*", "js//*", "webfonts//*"]- defaultStaticsPhony+ defaultStaticsPhony ["css//*", "images//*", "js//*", "webfonts//*"] defaultSinglePagePhony "index" "index.html" defaultPostsPhony ["posts/*.md"]@@ -101,7 +103,7 @@ logOptions' <- logOptionsHandle stdout True lf <- newLogFunc (setLogMinLevel LevelInfo logOptions') let f = ShakebookEnv (fst lf) sbc- shake shakeOptions $ want ["clean"] >> runShakebook f rules- shake shakeOptions $ want ["index", "docs", "month-index", "posts-index", "tag-index", "posts"] >> runShakebook f rules+ shake shakeOptions $ want ["clean"] >> runShakePlus f rules+ shake shakeOptions $ want ["index", "docs", "month-index", "posts-index", "tag-index", "posts"] >> runShakePlus f rules defaultMain $ tests xs snd lf