shakebook 0.2.2.0 → 0.3.0.0
raw patch · 13 files changed
+414/−605 lines, 13 filesdep +aeson-withdep +comonad-extras
Dependencies added: aeson-with, comonad-extras
Files
- ChangeLog.md +13/−0
- app/Main.hs +23/−8
- shakebook.cabal +9/−4
- src/Shakebook.hs +0/−2
- src/Shakebook/Aeson.hs +0/−31
- src/Shakebook/Conventions.hs +36/−20
- src/Shakebook/Data.hs +53/−90
- src/Shakebook/Defaults.hs +14/−356
- src/Shakebook/Feed.hs +6/−6
- src/Shakebook/Mustache.hs +2/−2
- src/Shakebook/Pandoc.hs +91/−0
- src/Shakebook/Rules.hs +0/−33
- test/Spec.hs +167/−53
ChangeLog.md view
@@ -1,5 +1,18 @@ # Changelog for Shakebook +## (v0.3.0.0)++* Upgrade to [shake-plus](https://hackage.haskell.org/package/shake-plus) v0.1.3.0+ to take advantage of new interface consistency.+* readMarkdownFile now extracts images from the pandoc and calls need on them.+* Removed most default code, moved back to user level.+* Tempate now uses caching for loading posts resulting in significant speedup.+* Add withSocialLinks function.+* Remove affix-style+* Add `sbGlobalApply` to apply a function on every page that comes into+ existence whether generated or loaded.+* Removed `Shakebook.Aeson` and moved to new library [aeson-with](https://hackage.haskell.org/package/aeson-with)+ ## (v0.2.2.0) * Depend on new experimental library
app/Main.hs view
@@ -1,13 +1,19 @@ {-# LANGUAGE TemplateHaskell #-} module Main where +import Control.Comonad.Env as E import Development.Shake.Plus import Options.Applicative import Path import RIO+import qualified RIO.HashMap as HM+import RIO.List import qualified RIO.Text as T import Shakebook+import Shakebook.Conventions+import Shakebook.Mustache import Shakebook.Defaults+import Within sample :: Parser SimpleOpts sample = SimpleOpts@@ -32,15 +38,12 @@ <> 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 s' <- parseRelDir (srcDir x) o' <- parseRelDir (outDir x)- app $ SbConfig s' o' (T.pack $ baseUrl x) defaultMarkdownReaderOptions defaultHtml5WriterOptions (ppp x)+ app $ SbConfig s' o' (T.pack $ baseUrl x) defaultMarkdownReaderOptions defaultHtml5WriterOptions (ppp x) id app :: SbConfig -> IO () app sbc = do@@ -54,12 +57,24 @@ runShakePlus f $ view sbConfigL >>= \SbConfig {..} -> do - defaultCleanPhony+ readMDC <- newCache loadMarkdownAsJSON - defaultSinglePagePattern "index.html" "templates/index.html"- (affixRecentPosts ["posts/md"] 5 defaultEnrichPost)+ postsC <- newCache $ \w -> do+ xs <- batchLoadWithin' w readMDC+ return $ defaultEnrichPost <$> xs - phony "index" $ needP [sbOutDir </> indexHTML]+ getRecentPosts <- newCache $ \fp -> do+ allPosts <- postsC fp+ return $ take 5 (sortOn (Down . viewPostTime) $ HM.elems allPosts)++ ("index.html" `within` sbOutDir) %^> \out -> do+ src <- blinkAndMapM sbSrcDir withMarkdownExtension $ out+ v <- readMDC src+ r <- getRecentPosts (["posts/*.md"] `within` sbSrcDir)+ let v' = withRecentPosts r v+ buildPageAction (sbSrcDir </> $(mkRelFile "template/index.html")) v' (fromWithin out)++ phony "index" $ needP [sbOutDir </> $(mkRelFile "index.html")] phony "all" $ need ["index"]
shakebook.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 81875743197319be0e2b8ba86e21804725439f8864b08a8528d09354faeb63de+-- hash: 6dd459b8ff1cb6bdb53664e12a74d78489bd1ab15a6e8ec4a01524e702472a9b name: shakebook-version: 0.2.2.0+version: 0.3.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@@ -24,13 +24,12 @@ library exposed-modules: Shakebook- Shakebook.Aeson Shakebook.Conventions Shakebook.Data Shakebook.Defaults Shakebook.Feed Shakebook.Mustache- Shakebook.Rules+ Shakebook.Pandoc other-modules: Paths_shakebook hs-source-dirs:@@ -39,8 +38,10 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints build-depends: aeson+ , aeson-with , base >=4.7 && <5 , comonad+ , comonad-extras , doctemplates , extra , feed@@ -72,8 +73,10 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: aeson+ , aeson-with , base >=4.7 && <5 , comonad+ , comonad-extras , doctemplates , extra , feed@@ -108,8 +111,10 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: aeson+ , aeson-with , base >=4.7 && <5 , comonad+ , comonad-extras , doctemplates , extra , feed
src/Shakebook.hs view
@@ -1,8 +1,6 @@ module Shakebook ( module Shakebook.Data-, module Shakebook.Rules ) where import Shakebook.Data-import Shakebook.Rules
− src/Shakebook/Aeson.hs
@@ -1,31 +0,0 @@-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}-module Shakebook.Aeson where--import Control.Lens-import Data.Aeson as A-import Data.Aeson.Lens-import RIO hiding (view)-import qualified RIO.HashMap as HML-import qualified RIO.Vector as V---- | Union two JSON values together.-withJSON :: (ToJSON a) => a -> Value -> Value-withJSON x (Object obj) = Object $ HML.union obj y- where Object y = toJSON x-withJSON _ _ = error "Can ony add a new TOJSON object to objects"---- | Add a String field to a JSON value.-withStringField :: Text -> Text -> Value -> Value-withStringField f v = _Object . at f ?~ String v---- | Add an Array field to a JSON value.-withArrayField :: Text -> [Value] -> Value -> Value-withArrayField f v = _Object . at f ?~ Array (V.fromList v)---- | Add an Object field to a JSON value.-withObjectField :: Text -> Value -> Value -> Value-withObjectField f v = _Object . at f ?~ v---- | Maybe add an Object field to a JSON value.-withObjectFieldMaybe :: Text -> Maybe Value -> Value -> Value-withObjectFieldMaybe f v = _Object . at f .~ v
src/Shakebook/Conventions.hs view
@@ -18,7 +18,8 @@ , withPrevious , withPosts , withRecentPosts-, withSrcPath+, withSocialLinks+, withSiteTitle , withSubsections , withTagIndex , withTagLinks@@ -56,6 +57,7 @@ import Control.Monad.Extra import Data.Aeson as A import Data.Aeson.Lens+import Data.Aeson.With import Data.Text.Time import RIO hiding (view) import RIO.List@@ -64,7 +66,6 @@ import qualified RIO.Text.Partial as T import RIO.Time import qualified RIO.Vector as V-import Shakebook.Aeson import Shakebook.Data import Text.Pandoc.Highlighting @@ -103,7 +104,7 @@ -- | Add "next" field from input Value. withNext :: Maybe Value -> (Value -> Value)-withNext = withObjectFieldMaybe "next"+withNext = withValueMaybe "next" -- | Add "pages" field from input [Value]. withPages :: [Value] -> (Value -> Value)@@ -111,31 +112,39 @@ -- | Add "prettydate" field using input Text. withPrettyDate :: Text -> Value -> Value-withPrettyDate = withStringField "prettydate"+withPrettyDate = withStringField "pretty-date" -- | Add "previous" field using input Value. withPrevious :: Maybe Value -> (Value -> Value)-withPrevious = withObjectFieldMaybe "previous"+withPrevious = withValueMaybe "previous" -- | Add "posts" field based on input [Value]. withPosts :: [Value] -> Value -> Value withPosts = withArrayField "posts" --- | Add "recentposts" field using input Value.+-- | Add "recent-posts" field using input Value. withRecentPosts :: [Value] -> Value -> Value withRecentPosts = withArrayField "recent-posts" --- | Add "subsections" field based on inpt [Value].+-- | Add "site-title" field from input Text.+withSiteTitle :: Text -> Value -> Value+withSiteTitle = withStringField "site-title"++-- | Add "social-links" field based on input [Value].+withSocialLinks :: [Value] -> Value -> Value+withSocialLinks = withArrayField "social-links"++-- | Add "subsections" field based on input [Value]. withSubsections :: [Value] -> (Value -> Value) withSubsections = withArrayField "subsections" --- | Add "tagindex" field based on input [Value].+-- | Add "tag-index" field based on input [Value]. withTagIndex :: [Value] -> Value -> Value-withTagIndex = withArrayField "tagindex"+withTagIndex = withArrayField "tag-index" --- | Add "taglinks" field based on input [Value].+-- | Add "tag-links" field based on input [Value]. withTagLinks :: [Value] -> Value -> Value-withTagLinks = withArrayField "taglinks"+withTagLinks = withArrayField "tag-links" -- | Add "teaser" field based on input Text. withTeaser :: Text -> Value -> Value@@ -151,7 +160,7 @@ -- | Assuming a "tags" field, enrich using withTagLinks. enrichTagLinks :: (Text -> Text) -> Value -> Value-enrichTagLinks f v = withTagLinks ((`genLinkData` f) <$> viewTags v) v+enrichTagLinks f v = withTagLinks ((genLinkData <*> f) <$> viewTags v) v -- | Assuming a "content" field with a spitter section, enrich using withTeaser enrichTeaser :: Text -> Value -> Value@@ -174,8 +183,8 @@ -- | Create link data object with fields "id" and "url" using an id and a function -- | transforming an id into a url.-genLinkData :: Text -> (Text -> Text) -> Value-genLinkData x f = object ["id" A..= String x, "url" A..= String (f x)]+genLinkData :: Text -> Text -> Value+genLinkData x u = object ["id" A..= String x, "url" A..= String u] -- | Filter a lists of posts by tag. tagFilterPosts :: Text -> [Value] -> [Value]@@ -224,16 +233,23 @@ toc2 (y :< ys) = (_Object . at "toc3" ?~ Array (V.fromList $ map extract ys)) y genPageData :: Text -> (Text -> Text) -> Zipper [] [Value] -> Value-genPageData t f xs = withTitle t- . withJSON (genLinkData (T.pack . show $ pos xs + 1) f)- . withPosts (extract xs) $ Object mempty+genPageData t f xs = let x = T.pack . show $ pos xs + 1+ in withTitle t+ . 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 :: MonadThrow m+genIndexPageData :: (MonadReader r m, HasSbConfig r, MonadThrow m) => [Value] -> Text -> (Text -> Text) -> Int -> m (Zipper [] Value)-genIndexPageData xs g h n = extend (genPageData g h) <$> paginate' n xs-+genIndexPageData xs g h n = do + zs <- paginate' n xs+ sequence $ extend (genPageDataM g h) zs
src/Shakebook/Data.hs view
@@ -1,35 +1,22 @@ {-# LANGUAGE TemplateHaskell #-} module Shakebook.Data where +import Control.Comonad.Env as E 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 Data.Aeson.With import Development.Shake.Plus-import qualified Development.Shake.FilePath import Path as P import RIO hiding (Lens', lens, view) import qualified RIO.Text as T-import Shakebook.Aeson+import Shakebook.Pandoc import Slick.Pandoc-import Text.Pandoc.Options+import Text.Pandoc 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@@ -37,35 +24,30 @@ 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 t => Display (WithinDisplay a t) where+ display (WithinDisplay (WithinT (EnvT e (Identity a)))) = display (PathDisplay e) <> "[" <> display a <> "]" -instance Display [WithinDisplay a t] where+instance Display t => Display [WithinDisplay a t] where display [] = "" display (x : xs) = display x <> " : " <> display xs -type ToC = Cofree [] String- data SbConfig = SbConfig- { sbSrcDir :: Path Rel Dir- , sbOutDir :: Path Rel Dir- , sbBaseUrl :: Text- , sbMdRead :: ReaderOptions- , sbHTWrite :: WriterOptions- , sbPPP :: Int+ { sbSrcDir :: Path Rel Dir+ , sbOutDir :: Path Rel Dir+ , sbBaseUrl :: Text+ , sbMdRead :: ReaderOptions+ , sbHTWrite :: WriterOptions+ , sbPPP :: Int+ , sbGlobalApply :: Value -> Value }- deriving (Show) -class HasSbConfig a where- sbConfigL :: Lens' a SbConfig- data ShakebookEnv = ShakebookEnv { logFunc :: LogFunc , sbConfig :: SbConfig } -instance HasLocalOut ShakebookEnv where- localOutL = lens (sbOutDir . sbConfig) undefined+class HasSbConfig a where+ sbConfigL :: Lens' a SbConfig instance HasSbConfig ShakebookEnv where sbConfigL = lens sbConfig undefined@@ -73,22 +55,34 @@ instance HasLogFunc ShakebookEnv where logFuncL = lens logFunc undefined --- | View the "srcPath" field of a JSON Value.+-- | View the "src-path" field of a JSON Value. viewSrcPath :: Value -> Text-viewSrcPath = view (key "srcPath" . _String)+viewSrcPath = view (key "src-path" . _String) --- | Add "srcPath" field based on input Text.+-- | Add "src-path" field based on input Text. withSrcPath :: Text -> Value -> Value-withSrcPath = withStringField "srcPath"+withSrcPath = withStringField "src-path" --- | Add "baseUrl" field from input Text.+-- | View the "base-url" of a JSON Value.+viewBaseUrl :: Value -> Text+viewBaseUrl = view (key "base-url" . _String)++-- | Add "base-url" field from input Text. withBaseUrl :: Text -> Value -> Value-withBaseUrl = withStringField "baseUrl"+withBaseUrl = withStringField "base-url" --- | Add "fullUrl" field from input Text.+-- | View the "full-url" of a JSON Value.+viewFullUrl :: Value -> Text+viewFullUrl = view (key "full-url" . _String)++-- | Add "full-url" field from input Text. withFullUrl :: Text -> Value -> Value-withFullUrl = withStringField "fullUrl"+withFullUrl = withStringField "full-url" +-- | View the "image" field of a JSON vaule.+viewImage :: Value -> Text+viewImage = view (key "image" . _String)+ -- | View the "url" field of a JSON Value. viewUrl :: Value -> Text viewUrl = view (key "url" . _String)@@ -101,7 +95,7 @@ enrichFullUrl :: Text -> Value -> Value enrichFullUrl base v = withFullUrl (base <> viewUrl v) v --- | Assuming a 'srcPath' field, enrich using withUrl using a Text -> Text transformation.+-- | Assuming a 'src-path' field, enrich using withUrl using a Text -> Text transformation. enrichUrl :: (Text -> Text) -> Value -> Value enrichUrl f v = withUrl (f (viewSrcPath v)) v @@ -114,6 +108,9 @@ withMarkdownExtension :: MonadThrow m => Path Rel File -> m (Path Rel File) withMarkdownExtension = replaceExtension ".md" +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 @@ -127,53 +124,19 @@ Get a JSON Value of Markdown Data with markdown body as "contents" field and the srcPath as "srcPath" field. -}-readMarkdownFile' :: (MonadReader r m, HasSbConfig r, MonadAction m)- => Within Rel File+loadMarkdownAsJSON :: (MonadReader r m, HasSbConfig r, MonadAction m, MonadThrow m)+ => Within Rel (Path 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)+loadMarkdownAsJSON srcPath = view sbConfigL >>= \SbConfig{..} -> do+ pdoc@(Pandoc meta _) <- readMDFileWithin sbMdRead srcPath+ meta' <- liftAction $ flattenMeta (writeHtml5String sbHTWrite) meta+ needPandocImagesIn sbOutDir pdoc+ outText <- runPandocA $ writeHtml5String sbHTWrite pdoc+ let docData = meta' & _Object . at "content" ?~ String outText+ supposedUrl <- liftIO $ (leadingSlash </>) <$> withHtmlExtension (extract srcPath)+ return $ sbGlobalApply+ . withSrcPath (T.pack . toFilePath $ extract srcPath) . withUrl (T.pack . toFilePath $ supposedUrl) $ docData -data PaginationException = EmptyContentsError- deriving (Show, Eq, Typeable)--instance Exception PaginationException where- displayException EmptyContentsError = "Can not create a Zipper of length zero."--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- data before you write. See the examples in Shakebook.Defaults--}-loadSortFilterEnrich :: (MonadShakebookAction r m, Ord b)- => [FilePattern] -- ^ A shake filepattern to load, relative to srcDir from SbConfig.- -> (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 [(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 [(Within Rel File, Value)] -- ^ A list of Values index by their srcPath.-loadSortEnrich pat s = loadSortFilterEnrich pat s (const True)+immediateShoots :: Cofree [] a -> [a]+immediateShoots(_ :< xs) = extract <$> xs
src/Shakebook/Defaults.hs view
@@ -1,40 +1,22 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} module Shakebook.Defaults where -import Control.Comonad import Control.Comonad.Cofree-import Control.Comonad.Store.Class-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.Plus-import qualified Development.Shake.FilePath as S import RIO import qualified RIO.ByteString.Lazy as LBS-import RIO.List-import RIO.List.Partial import qualified RIO.Map as M-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.Mustache+import Shakebook.Pandoc import Text.DocTemplates-import Text.Pandoc.Class import Text.Pandoc.Definition import Text.Pandoc.Options-import Text.Pandoc.PDF-import Text.Pandoc.Readers-import Text.Pandoc.Templates-import Text.Pandoc.Walk-import Text.Pandoc.Writers-import Within defaultMonthUrlFormat :: UTCTime -> String defaultMonthUrlFormat = formatTime defaultTimeLocale "%Y-%m"@@ -45,14 +27,6 @@ defaultPrettyTimeFormat :: UTCTime -> String defaultPrettyTimeFormat = formatTime defaultTimeLocale "%A, %B %d, %Y" -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 @@ -70,338 +44,22 @@ defaultLatexWriterOptions :: WriterOptions defaultLatexWriterOptions = def { writerTableOfContents = True- , writerVariables = Context $ M.fromList [+ , writerVariables = Context $ M.fromList [ ("geometry", SimpleVal "margin=3cm") , ("fontsize", SimpleVal "10") , ("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 defaultSbSrcDir defaultSbOutDir x defaultMarkdownReaderOptions defaultHtml5WriterOptions defaultPostsPerPage--affixBlogNavbar :: MonadShakebookAction r m- => [FilePattern]- -> Text- -> Text- -> (UTCTime -> Text)- -> (UTCTime -> Text)- -> (Value -> Value) -- ^ Post enrichment.- -> Value -> m Value-affixBlogNavbar patterns a b c d e x = do- xs <- loadSortEnrich patterns (Down . viewPostTime) e- return $ withJSON (genBlogNavbarData a b c d (snd <$> xs)) $ x--affixRecentPosts :: MonadShakebookAction r m- => [FilePattern]- -> Int- -> (Value -> Value) -- ^ Post enrichment- -> Value -> m Value-affixRecentPosts patterns n e x = do- xs <- loadSortEnrich patterns (Down . viewPostTime) e- return $ withRecentPosts (take n (snd <$> xs)) $ x----defaultDocsPatterns :: (MonadShakebookRules r m)- => Cofree [] FilePath -- Rosetree Table of Contents.- -> FilePath- -> (Value -> Value) -- Extra data modifiers.- -> m ()-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]- -> (a -> Value -> Bool) -- ^ A filtering function - -> (a -> Text) -- ^ How to turn the id into a Title.- -> (a -> Text -> Text) -- ^ How to turn the id and a page number (as Text) into a URL link.- -> a -- ^ The id itself.- -> 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- ys <- genIndexPageData (snd <$> xs) (t a) (l a) sbPPP- return ys--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 -> RAction r (Zipper [] Value))- -> (Zipper [] Value -> RAction r (Zipper [] Value))- -> m ()-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 -> RAction r (Zipper [] Value)) -- ^ Pager extension.- -> m ()-defaultPostIndexPatterns pat tmpl extData = do- defaultPagerPattern "posts/index.html" tmpl- (const 0)- (const ())- (defaultPostIndexData pat (const $ (const True))- (const "Posts")- (const ("/posts/pages/" <>)))- extData- defaultPagerPattern ("posts/pages/*/index.html") tmpl- ((+ (-1)) . read . (!! 2) . splitOn "/")- (const ())- (defaultPostIndexData pat (const $ (const True))- (const "Posts")- (const ("/posts/pages/" <>)))- extData--defaultTagIndexPatterns :: MonadShakebookRules r m- => [FilePattern]- -> FilePath- -> (Zipper [] Value -> RAction r (Zipper [] Value)) -- ^ Pager extension.- -> m ()-defaultTagIndexPatterns pat tmpl extData = do- defaultPagerPattern ("posts/tags/*/index.html") tmpl- (const 0)- (T.pack . (!! 2) . splitOn "/")- (defaultPostIndexData pat (\x y -> elem x (viewTags y) )- ("Posts tagged " <>)- (\x y -> ("/posts/tags/" <> x <> "/pages/" <> y)))- extData- defaultPagerPattern ("posts/tags/*/pages/*/index.html") tmpl- ((+ (-1)) . read . (!! 4) . splitOn "/")- (T.pack . (!! 2) . splitOn "/")- (defaultPostIndexData pat (\x y -> elem x (viewTags y))- ("Posts tagged " <>)- (\x y -> ("/posts/tags/" <> x <> "/pages/" <> y)))- extData--defaultMonthIndexPatterns :: MonadShakebookRules r m- => [FilePattern]- -> FilePath- -> (Zipper [] Value -> RAction r (Zipper [] Value)) -- ^ Pager extension.- -> m ()-defaultMonthIndexPatterns pat tmpl extData = do- defaultPagerPattern "posts/months/*/index.html" tmpl- (const 0)- (parseISODateTime . T.pack . (!! 2) . splitOn "/")- (defaultPostIndexData pat- (\x y -> sameMonth x (viewPostTime y))- (("Posts from " <>) . T.pack . defaultPrettyMonthFormat)- (\x y -> ("/posts/months/" <> T.pack (defaultMonthUrlFormat x) <> "/pages" <> y)))- extData- defaultPagerPattern "posts/months/*/pages/*/index.html" tmpl- ((+ (-1)) . read . (!! 4) . splitOn "/")- (parseISODateTime . T.pack . (!! 2) . splitOn "/")- (defaultPostIndexData pat- (\x y -> sameMonth x (viewPostTime y))- (("Posts from " <>) . T.pack . defaultPrettyMonthFormat)- (\x y -> ("/posts/months/" <> T.pack (defaultMonthUrlFormat x) <> "/pages" <> y)))- extData--{-|- Default Posts Pager. --}-defaultPostsPatterns :: MonadShakebookRules r m- => FilePattern- -> FilePath- -> (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 = 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 -> 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 (prefix <> "/" <> src, txt)-handleImages _ _ x = x--handleHeaders :: Int -> Block -> Block-handleHeaders i (Header a as xs) = Header (max 1 (a + i)) as xs-handleHeaders _ x = x+ } -pushHeaders :: Int -> Cofree [] Pandoc -> Cofree [] Pandoc-pushHeaders i (x :< xs) = walk (handleHeaders i) x :< map (pushHeaders (i+1)) xs+defaultVideoReplacement :: Text -> Text -> Inline+defaultVideoReplacement baseUrl = \x -> Str $ "[Video available at [" <> baseUrl <> "/" <> x <> "]" --- | Build a PDF from a Cofree table of contents.-buildPDF :: (MonadShakebookAction r m, MonadFail m) => Cofree [] String -> Path Rel File -> FilePath -> m ()+--- | 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- y <- mapM (readFileIn' sbSrcDir <=< parseRelFile) toc- m <- readFileIn' sbSrcDir meta- Right f <- liftIO . runIOorExplode $ do- 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--{-|- Default Single Page Pattern, see tests for usage. It's possible this could just be- called singlePagePattern, as there's no hardcoded strings here, but it would need to- run entirely within the monad to translate filepaths.--}-defaultSinglePagePattern :: (MonadRules m, MonadReader r m, HasSbConfig r, HasLocalOut r)- => FilePath -- ^ The output filename e.g "index.html".- -> FilePath -- ^ A tmpl file.- -> (Value -> RAction r Value) -- ^ Last minute enrichment.- -> m ()-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- 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 {..} -> - phony "clean" $ do- logInfo $ "Cleaning files in " <> display (PathDisplay sbOutDir)- removeFilesAfter sbOutDir ["//*"]--defaultSinglePagePhony :: MonadShakebookRules r m => String -> FilePath -> m ()-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 => [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{..} -> - 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 = view sbConfigL >>= \SbConfig{..} ->- phony "posts-index" $ do- 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- discover and calls need on "\<out\>\/posts\/tags\/\<tag\>\/index.html" and- "\<out\>\/posts\/tags\/\<tag\>\/pages\/\<n\>\/index.html" for each tag discovered and for- each page required per tag filter.--}-defaultTagIndexPhony :: MonadShakebookRules r m => [FilePattern] -> m ()-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 :: (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 - -> m ()-defaultDocsPhony toc = view sbConfigL >>= \SbConfig{..} ->- phony "docs" $ do- let xs = foldr ((<>) . pure) [] $ toc- pure xs >>= mapM (parseRelFile >=> withHtmlExtension) >>= needIn sbOutDir+ 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
src/Shakebook/Feed.hs view
@@ -4,26 +4,26 @@ ) where import Data.Aeson-import Development.Shake+import Development.Shake.Plus+import Path import RIO import RIO.List.Partial-import qualified RIO.Text as T import qualified RIO.Text.Lazy as TL import Shakebook.Conventions import Shakebook.Data import Text.Atom.Feed as Atom import Text.Atom.Feed.Export --- Convert a Post to an Atom Entry+-- | Convert a Post to an Atom Entry asAtomEntry :: Value -> Atom.Entry asAtomEntry x = (Atom.nullEntry (viewUrl x) (Atom.TextString $ viewTitle x) (viewPostTimeRaw x)) { Atom.entryContent = Just $ Atom.TextContent (viewContent x) } --- Build an Atom Feed from a list of posts.-buildFeed :: Text -> Text -> [Value] -> FilePath -> Action ()+-- | Build an Atom Feed from a list of posts.+buildFeed :: MonadAction m => Text -> Text -> [Value] -> Path Rel File -> m () buildFeed title baseUrl xs out = do let fs = asAtomEntry <$> dateSortPosts xs let t = Atom.nullFeed baseUrl (Atom.TextString title) $ Atom.entryUpdated (head fs) case textFeed (t { Atom.feedEntries = fs }) of- Just a -> writeFile' out (T.unpack . TL.toStrict $ a)+ Just a -> writeFile' out $ TL.toStrict a Nothing -> return ()
src/Shakebook/Mustache.hs view
@@ -36,8 +36,8 @@ writeFile' out $ substitute pageT value buildPageActionWithin :: MonadAction m- => Within Rel File+ => Within Rel (Path Rel File) -> Value- -> Within Rel File+ -> Within Rel (Path Rel File) -> m () buildPageActionWithin template value out = buildPageAction (fromWithin template) value (fromWithin out)
+ src/Shakebook/Pandoc.hs view
@@ -0,0 +1,91 @@+module Shakebook.Pandoc (+ runPandocA+, PandocActionException(..)+, readMDFile+, readMDFileIn+, readMDFileWithin+, needPandocImagesIn+, makePDFLaTeX+, progressivelyDemoteHeaders+, replaceUnusableImages+, prefixAllImages+) where++import Control.Comonad.Cofree+import Development.Shake.Plus+import RIO+import qualified RIO.ByteString.Lazy as LBS+import qualified RIO.Text as T+import Path+import Text.Pandoc.Class+import Text.Pandoc.Definition+import Text.Pandoc.Readers+import Text.Pandoc.Options+import Text.Pandoc.PDF+import Text.Pandoc.Templates+import Text.Pandoc.Walk+import Text.Pandoc.Writers+import Within++data PandocActionException = PandocActionException String+ deriving (Show, Eq, Typeable)++instance Exception PandocActionException where+ displayException (PandocActionException s) = s++-- | Natural transformation from `PandocIO` to a `MonadAction`+runPandocA :: (MonadAction m, MonadThrow m ) => PandocIO a -> m a+runPandocA p = do+ result <- liftIO $ runIO p+ either throwM return result++-- | Read a markdown file as an Action.+readMDFile :: (MonadAction m, MonadThrow m) => ReaderOptions -> Path Rel File -> m Pandoc+readMDFile ropts src = readFile' src >>= runPandocA . readMarkdown ropts++-- | Read a markdown file as an Action.+readMDFileIn :: (MonadAction m, MonadThrow m) => ReaderOptions -> Path Rel Dir -> Path Rel File -> m Pandoc+readMDFileIn ropts dir src = readFile' (dir </> src) >>= runPandocA . readMarkdown ropts++-- | Like `readMDFile` but accepts a `Within`+readMDFileWithin :: (MonadAction m, MonadThrow m) => ReaderOptions -> Within Rel (Path Rel File) -> m Pandoc+readMDFileWithin ropts src = readMDFile ropts (fromWithin src)++-- | Find all the images in a `Pandoc` data structure and call `Development.Shake.Plus.need` on them.+needPandocImagesIn :: (MonadAction m, MonadThrow m) => Path Rel Dir -> Pandoc -> m ()+needPandocImagesIn outDir pdoc =+ mapM parseRelFile (fmap (drop 1 . T.unpack) $ pullImages pdoc) >>= needIn outDir where+ pullImages = query f+ f (Image _ _ (src, _)) = [src]+ 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++-- | 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+-- will be lower in the table of contents in the PDF equivalent.+progressivelyDemoteHeaders :: Cofree [] Pandoc -> Cofree [] Pandoc+progressivelyDemoteHeaders = pushHeaders (0) where+ handleHeaders :: Int -> Block -> Block+ handleHeaders i (Header a as xs) = Header (max 1 (a + i)) as xs+ handleHeaders _ x = x++ pushHeaders :: Int -> Cofree [] Pandoc -> Cofree [] Pandoc+ pushHeaders i (x :< xs) = walk (handleHeaders i) x :< map (pushHeaders (i+1)) xs++-- | For a list of file extensions, replace the images with an Inline based on its src path.+replaceUnusableImages :: MonadThrow m => [String] -> (Text -> Inline) -> Pandoc -> m (Pandoc)+replaceUnusableImages exts f = walkM handleImages where+ handleImages i@(Image _ _ (src, _)) = do+ x <- parseRelFile (T.unpack src) >>= fileExtension+ return $ if elem x exts then f src else i+ handleImages x = return x++prefixAllImages :: Path Rel Dir -> Pandoc -> Pandoc+prefixAllImages dir = walk handleImages where+ handleImages (Image attr ins (src, txt)) = Image attr ins ((T.pack $ toFilePath dir) <> "/" <> src, txt)+ handleImages x = x
− src/Shakebook/Rules.hs
@@ -1,33 +0,0 @@-module Shakebook.Rules where--import Control.Comonad.Cofree-import Control.Comonad.Store-import Development.Shake-import RIO--{-|- Generates Shake `Rules` from a FilePattern via an action that returns a `ComonadStore`.--}-comonadStoreRuleGen :: ComonadStore s w- => FilePattern -- ^ The filepattern rule.- -> (FilePattern -> s) -- ^ How to extract a position marker from the filepattern.- -> (FilePattern -> a) -- ^ How to extract an id from the filepattern.- -> (a -> Action (w b)) -- ^ How to turn the id into a searchable store.- -> (b -> FilePath -> Action ())- -> Rules ()-comonadStoreRuleGen fp f g h k =- fp %> \x -> do- xs <- h (g x)- k (extract (seek (f x) xs)) x--{-|- Generates Shake `Rules` from a `ComonadCofree` of `FilePath` sources.--}-cofreeRuleGen :: (Traversable w, ComonadCofree f w)- => w FilePath -- ^ A cofree comonad of FilePaths- -> (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- let f ys = h (extract ys) %> k ys- void . sequence . extend f $ xs
test/Spec.hs view
@@ -1,95 +1,209 @@ {-# LANGUAGE TemplateHaskell #-}+ import Control.Comonad.Cofree+import Control.Comonad.Store+import Control.Comonad.Store.Zipper import Control.Comonad.Zipper.Extra import Data.Aeson+import Data.Aeson.With import Data.List.Split+import Data.Text.Time import Development.Shake.Plus import Path import RIO+import RIO.Partial+import qualified RIO.HashMap as HM import RIO.List+import RIO.List.Partial import qualified RIO.Text as T-import Shakebook-import Shakebook.Aeson-import Shakebook.Conventions+import Shakebook.Data import Shakebook.Defaults+import Shakebook.Mustache+import Shakebook.Conventions import Test.Tasty import Test.Tasty.Golden import Text.Pandoc.Highlighting+import Within -srcDir :: Path Rel Dir-srcDir = $(mkRelDir "test/site")+sourceFolder :: Path Rel Dir+sourceFolder = $(mkRelDir "test/site") -outDir :: Path Rel Dir-outDir = $(mkRelDir "test/public")+outputFolder :: Path Rel Dir+outputFolder = $(mkRelDir "test/public") baseUrl :: Text baseUrl = "http://blanky.test" -toc :: ToC-toc = "docs/index.md" :< [- "docs/1/index.md" :< []- , "docs/2/index.md" :< [- "docs/2/champ.md" :< []- ]- ]+siteTitle :: Text+siteTitle = "Blanky Site" -myBlogNavbar :: [Value] -> Value-myBlogNavbar = genBlogNavbarData "Blog" "/posts/" (T.pack . defaultPrettyMonthFormat) (defaultMonthUrlFragment)+tableOfContents :: Cofree [] (Path Rel File)+tableOfContents = $(mkRelFile "docs/index.md") :< [+ $(mkRelFile "docs/1/index.md") :< []+ , $(mkRelFile "docs/2/index.md") :< [+ $(mkRelFile "docs/2/champ.md") :< []+ ]+ ] numRecentPosts :: Int numRecentPosts = 3 -numPageNeighbours :: Int-numPageNeighbours = 1+--numPageNeighbours :: Int+--numPageNeighbours = 1 +postsPerPage :: Int+postsPerPage = 5++mySocial :: [Value]+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 srcDir outDir baseUrl defaultMarkdownReaderOptions defaultHtml5WriterOptions 5+sbc = SbConfig {+ sbSrcDir = sourceFolder+, sbOutDir = outputFolder+, sbBaseUrl = baseUrl+, sbMdRead = defaultMarkdownReaderOptions+, sbHTWrite = defaultHtml5WriterOptions+, sbPPP = postsPerPage+, sbGlobalApply = withSiteTitle siteTitle . withHighlighting pygments . withSocialLinks mySocial+} -extendPostsZipper :: MonadShakebookAction r m => Zipper [] Value -> m (Zipper [] Value)-extendPostsZipper = return+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 -enrichPostIndexPage :: MonadShakebookAction r m => [FilePattern] -> Zipper [] Value -> m (Zipper [] Value)-enrichPostIndexPage patterns x = do- sortedPosts <- loadSortEnrich patterns (Down . viewPostTime) defaultEnrichPost- return $ fmap (withJSON (myBlogNavbar (snd <$> sortedPosts)))- . extendPageNeighbours numPageNeighbours $ x+rules :: ShakePlus ShakebookEnv ()+rules = view sbConfigL >>= \SbConfig {..} -> do -rules :: MonadShakebookRules r m => m ()-rules = do- defaultSinglePagePattern "index.html" "templates/index.html"- (affixRecentPosts ["posts/*.md"] numRecentPosts defaultEnrichPost)+ readMDC <- newCache loadMarkdownAsJSON - defaultPostsPatterns "posts/*.html" "templates/post.html"- (affixBlogNavbar ["posts/*.md"] "Blog" "/posts/" (T.pack . defaultPrettyMonthFormat) (defaultMonthUrlFragment) defaultEnrichPost- <=< affixRecentPosts ["posts/*.md"] numRecentPosts defaultEnrichPost- . defaultEnrichPost . withHighlighting pygments)- extendPostsZipper+ postsC <- newCache $ \w -> do+ xs <- batchLoadWithin' w readMDC+ return $ defaultEnrichPost <$> xs - defaultDocsPatterns toc "templates/docs.html"- (withHighlighting pygments)+ sortedPosts <- newCache $ \fp -> do+ allPosts <- postsC fp+ return $ sortOn (Down . viewPostTime . snd) $ HM.toList allPosts - defaultPostIndexPatterns ["posts/*.md"] "templates/post-list.html"- (enrichPostIndexPage ["posts/*.md"])+ getRecentPosts <- newCache $ \fp -> do+ xs <- sortedPosts fp+ return $ take numRecentPosts (snd <$> xs) - defaultTagIndexPatterns ["posts/*.md"] "templates/post-list.html"- (enrichPostIndexPage ["posts/*.md"])+ getBlogNavbar <- newCache $ \fp -> do+ allPosts <- postsC fp+ return $ genBlogNavbarData "Blog" "/posts/"+ (T.pack . defaultPrettyMonthFormat)+ (defaultMonthUrlFragment) (HM.elems allPosts) - defaultMonthIndexPatterns ["posts/*.md"] "templates/post-list.html"- (enrichPostIndexPage ["posts/*.md"])- defaultStaticsPatterns ["css//*", "images//*", "js//*", "webfonts//*"]- defaultStaticsPhony ["css//*", "images//*", "js//*", "webfonts//*"]+ let myPosts = ["posts/*.md"] `within` sbSrcDir - defaultSinglePagePhony "index" "index.html"- defaultPostsPhony ["posts/*.md"]- defaultPostIndexPhony ["posts/*.md"]+ ("index.html" `within` sbOutDir) %^> \out -> do+ src <- blinkAndMapM sbSrcDir withMarkdownExtension $ out+ v <- readMDC src+ r <- getRecentPosts myPosts+ let v' = withRecentPosts r v+ buildPageActionWithin ($(mkRelFile "templates/index.html") `within` sbSrcDir) v' out - defaultTagIndexPhony ["posts/*.md"]+ ("posts/*.html" `within` sbOutDir) %^> \out -> do+ src <- blinkAndMapM sbSrcDir 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 - defaultMonthIndexPhony ["posts/*.md"]+ toc' <- mapM (mapM withHtmlExtension) $ fmap (`within` sbOutDir) tableOfContents+ void . sequence . flip extend toc' $ \xs -> (fmap toFilePath $ extract xs) %^> \out -> do+ let getDoc = readMDC <=< blinkAndMapM sbSrcDir 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 - defaultDocsPhony toc- defaultCleanPhony+ ("posts/index.html" `within` sbOutDir) %^>+ copyFileChangedWithin ($(mkRelFile "posts/pages/1/index.html") `within` sbOutDir) + ("posts/pages/*/index.html" `within` sbOutDir) %^> \out -> do+ xs <- sortedPosts myPosts+ let n = (+ (-1)) . read . (!! 2) . splitOn "/" . toFilePath . extract $ out+ p <- seek n <$> genIndexPageData (snd <$> xs) "Posts" ("/posts/pages" <>) sbPPP+ k <- getBlogNavbar myPosts+ let v = withJSON k $ extract p+ buildPageActionWithin ($(mkRelFile "templates/post-list.html") `within` sbSrcDir) v out+ + ("posts/tags/*/index.html" `within` sbOutDir) %^> \out -> do+ let t = (!! 2) . splitOn "/" . toFilePath . extract $ out+ i <- parseRelFile $ "posts/tags/" <> t <> "/pages/1/index.html"+ copyFileChangedWithin (i `within` sbOutDir) out++ ("posts/tags/*/pages/*/index.html" `within` sbOutDir) %^> \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+ k <- getBlogNavbar myPosts+ let v = withJSON k $ extract p+ buildPageActionWithin ($(mkRelFile "templates/post-list.html") `within` sbSrcDir) v out++ ("posts/months/*/index.html" `within` sbOutDir) %^> \out -> do+ let t = (!! 2) . splitOn "/" . toFilePath . extract $ out+ i <- parseRelFile $ "posts/months/" <> t <> "/pages/1/index.html"+ copyFileChangedWithin (i `within` sbOutDir) out++ ("posts/months/*/pages/*/index.html" `within` sbOutDir) %^> \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+ k <- getBlogNavbar myPosts+ let v = withJSON k $ extract p+ buildPageActionWithin ($(mkRelFile "templates/post-list.html") `within` sbSrcDir) v out++ phony "index" $+ needIn sbOutDir [$(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++ 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++ 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++ phony "docs" $+ mapM withHtmlExtension tableOfContents >>= needIn sbOutDir+ + phony "posts" $+ getDirectoryFilesWithin' (["posts/*.md"] `within` sbSrcDir) >>= + mapM (blinkAndMapM sbOutDir withHtmlExtension) >>=+ needWithin'++ phony "clean" $ do+ logInfo $ "Cleaning files in " <> display (PathDisplay sbOutDir)+ removeFilesAfter sbOutDir ["//*"]+ tests :: [FilePath] -> TestTree tests xs = testGroup "Rendering Tests" $ map ( \x -> goldenVsFile x x@@ -104,6 +218,6 @@ lf <- newLogFunc (setLogMinLevel LevelInfo logOptions') let f = ShakebookEnv (fst lf) sbc shake shakeOptions $ want ["clean"] >> runShakePlus f rules- shake shakeOptions $ want ["index", "docs", "month-index", "posts-index", "tag-index", "posts"] >> 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 defaultMain $ tests xs snd lf