shakebook 0.1.5.1 → 0.2.0.0
raw patch · 10 files changed
+685/−326 lines, 10 filesdep +optparse-applicativedep +tasty-goldennew-component:exe:shakebook-simple-blog
Dependencies added: optparse-applicative, tasty-golden
Files
- app/Main.hs +61/−0
- shakebook.cabal +37/−5
- src/Shakebook/Aeson.hs +10/−9
- src/Shakebook/Conventions.hs +61/−102
- src/Shakebook/Data.hs +162/−67
- src/Shakebook/Defaults.hs +217/−118
- src/Shakebook/Feed.hs +13/−11
- src/Shakebook/Rules.hs +15/−9
- src/Shakebook/Zipper.hs +4/−4
- test/Spec.hs +105/−1
+ app/Main.hs view
@@ -0,0 +1,61 @@+module Main where++import Development.Shake+import Development.Shake.FilePath+import Options.Applicative+import RIO+import qualified RIO.Text as T+import Shakebook+import Shakebook.Defaults++sample :: Parser SimpleOpts+sample = SimpleOpts+ <$> strOption ( long "src" <> metavar "SOURCEDIR" <> help "The source directory."+ <> showDefault <> value "site" )+ <*> strOption ( long "out" <> metavar "OUTPUTDIR" <> help "The output directory."+ <> showDefault <> value "public")+ <*> strOption ( long "baseUrl" <> metavar "BASEURL" <> help "The base url for your site.")+ <*> option auto ( long "ppp" <> metavar "POSTSPERPAGE" <> help "Num of posts per page.")+++data SimpleOpts = SimpleOpts+ { srcDir :: String+ , outDir :: String+ , baseUrl :: String+ , ppp :: Int+ }++opts :: ParserInfo SimpleOpts+opts = info (sample <**> helper)+ ( fullDesc+ <> progDesc "Creates a simple blog from source with default settings."+ <> header "shakebook-simple-blog - A simple blog using standard shakebook conventions." )++main :: IO ()+main = do+ (x :: SimpleOpts) <- execParser opts++ app $ SbConfig (srcDir x) (outDir x) (T.pack $ baseUrl x) defaultMarkdownReaderOptions defaultHtml5WriterOptions (ppp x)++app :: SbConfig -> IO ()+app sbc = do+ logOptions' <- logOptionsHandle stdout True+ lf <- newLogFunc logOptions'+ let f = ShakebookEnv (fst lf) sbc++ shake (shakeOptions { shakeVerbosity = Chatty, shakeLintInside = ["\\"] }) $ do++ want ["all"]++ runShakebook 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 "all" $ need ["index"]++ snd lf
shakebook.cabal view
@@ -4,14 +4,15 @@ -- -- see: https://github.com/sol/hpack ----- hash: 0c68188b78917b12d682a029eea391ab336b75d8a9686896ed36ebab467323d9+-- hash: 353194af235845486622da7de4d10314e4569f0b886a6368e261993ae8f34384 name: shakebook-version: 0.1.5.1-synopsis: Shake-based technical documentation generator.+version: 0.2.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 author: Daniel Firth-maintainer: dan.firt@homotopic.tech+maintainer: dan.firth@homotopic.tech copyright: 2020 Daniel Firth license: MIT license-file: LICENSE@@ -54,10 +55,40 @@ , shake , slick , split- , tasty , text-time default-language: Haskell2010 +executable shakebook-simple-blog+ main-is: Main.hs+ other-modules:+ Paths_shakebook+ hs-source-dirs:+ app+ default-extensions: BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeSynonymInstances ViewPatterns+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , base >=4.7 && <5+ , comonad+ , comonad-extras+ , doctemplates+ , extra+ , feed+ , free+ , lens+ , lens-aeson+ , optparse-applicative+ , pandoc+ , pandoc-types+ , relude+ , rio+ , shake+ , shakebook+ , slick+ , split+ , text-time+ default-language: Haskell2010+ test-suite shakebook-test type: exitcode-stdio-1.0 main-is: Spec.hs@@ -87,5 +118,6 @@ , slick , split , tasty+ , tasty-golden , text-time default-language: Haskell2010
src/Shakebook/Aeson.hs view
@@ -1,30 +1,31 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Shakebook.Aeson where import Control.Lens-import Data.Aeson as A+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+import RIO hiding (view)+import qualified RIO.HashMap as HML+import qualified RIO.Vector as V --- Union two JSON values together.+-- | 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.+-- | 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.+-- | 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.+-- | 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.+-- | 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
@@ -9,11 +9,8 @@ , viewSrcPath , viewTags , viewTitle-, viewUrl , viewAllPostTags , viewAllPostTimes-, withBaseUrl-, withFullUrl , withHighlighting , withNext , withPages@@ -27,17 +24,12 @@ , withTagLinks , withTeaser , withTitle-, withUrl - -- * Enrichment-, enrichFullUrl+ -- * Enrichments , enrichPrettyDate , enrichTagLinks , enrichTeaser-, enrichTypicalUrl - -- * Affixes- -- * Extensions , extendNext , extendPrevious@@ -46,6 +38,7 @@ -- * Generations , genBlogNavbarData+, genIndexPageData , genLinkData , genPageData , genTocNavbarData@@ -64,7 +57,6 @@ import Data.Aeson as A import Data.Aeson.Lens import Data.Text.Time-import Development.Shake.FilePath import RIO hiding (view) import RIO.List import RIO.List.Partial@@ -73,170 +65,128 @@ import RIO.Time import qualified RIO.Vector as V import Shakebook.Aeson+import Shakebook.Data import Shakebook.Zipper import Text.Pandoc.Highlighting --- View the "content" field of a JSON Value.+-- | View the "content" field of a JSON Value. viewContent :: Value -> Text viewContent = view (key "content" . _String) --- View the "date" field of a JSON Value as a UTCTime.+-- | View the "date" field of a JSON Value as a UTCTime. viewPostTime :: Value -> UTCTime viewPostTime = parseISODateTime . view (key "date" . _String) --- View the "date" field of a JSON Value as Text.+-- | View the "date" field of a JSON Value as Text. viewPostTimeRaw :: Value -> Text viewPostTimeRaw = view (key "date" . _String) --- View the "srcPath" field of a JSON Value.-viewSrcPath :: Value -> Text-viewSrcPath = view (key "srcPath" . _String)---- View the "tags" field of a JSON Value as a list.+-- | View the "tags" field of a JSON Value as a list. viewTags :: Value -> [Text] viewTags = toListOf (key "tags" . values . _String) --- View the "title" field of a JSON Value.+-- | View the "title" field of a JSON Value. viewTitle :: Value -> Text viewTitle = view (key "title" . _String) --- View the "url" field of a JSON Value.-viewUrl :: Value -> Text-viewUrl = view (key "url" . _String)---- View all post tags for a list of posts.+-- | View all post tags for a list of posts. viewAllPostTags :: [Value] -> [Text] viewAllPostTags = (>>= viewTags) --- View all posts times for a list of posts.+-- | View all posts times for a list of posts. viewAllPostTimes :: [Value] -> [UTCTime] viewAllPostTimes = fmap viewPostTime --- Add "baseUrl" field from input Text.-withBaseUrl :: Text -> Value -> Value-withBaseUrl = withStringField "baseUrl"---- Add "fullUrl" field from input Text.-withFullUrl :: Text -> Value -> Value-withFullUrl = withStringField "fullUrl"---- Add "highlighting-css" field from input Style.+-- | Add "highlighting-css" field from input Style. withHighlighting :: Style -> Value -> Value withHighlighting = withStringField "highlighting-css" . T.pack . styleToCss --- Add "next" field from input Value.+-- | Add "next" field from input Value. withNext :: Maybe Value -> (Value -> Value) withNext = withObjectFieldMaybe "next" --- Add "pages" field from input [Value].+-- | Add "pages" field from input [Value]. withPages :: [Value] -> (Value -> Value) withPages = withArrayField "pages" --- Add "prettydate" field using input Text.+-- | Add "prettydate" field using input Text. withPrettyDate :: Text -> Value -> Value withPrettyDate = withStringField "prettydate" --- Add "previous" field using input Value.+-- | Add "previous" field using input Value. withPrevious :: Maybe Value -> (Value -> Value) withPrevious = withObjectFieldMaybe "previous" --- Add "posts" field based on input [Value].+-- | Add "posts" field based on input [Value]. withPosts :: [Value] -> Value -> Value withPosts = withArrayField "posts" --- Add "recentposts" field using input Value. +-- | Add "recentposts" field using input Value. withRecentPosts :: [Value] -> Value -> Value-withRecentPosts = withArrayField "recent-posts" ---- Add "srcPath" field based on input Text.-withSrcPath :: Text -> Value -> Value-withSrcPath = withStringField "srcPath"+withRecentPosts = withArrayField "recent-posts" --- Add "subsections" field based on inpt [Value].+-- | Add "subsections" field based on inpt [Value]. withSubsections :: [Value] -> (Value -> Value) withSubsections = withArrayField "subsections" --- Add "tagindex" field based on input [Value].+-- | Add "tagindex" field based on input [Value]. withTagIndex :: [Value] -> Value -> Value withTagIndex = withArrayField "tagindex" --- Add "taglinks" field based on input [Value].+-- | Add "taglinks" field based on input [Value]. withTagLinks :: [Value] -> Value -> Value withTagLinks = withArrayField "taglinks" --- Add "teaser" field based on input Text.+-- | Add "teaser" field based on input Text. withTeaser :: Text -> Value -> Value withTeaser = withStringField "teaser" --- Add "title" field based on input Text.+-- | Add "title" field based on input Text. withTitle :: Text -> Value -> Value withTitle = withStringField "title" --- Add "url" field from input Text.-withUrl :: Text -> Value -> Value-withUrl = withStringField "url"+-- | Assuming a "date" field, enrich using withPrettyDate and a format string.+enrichPrettyDate :: (UTCTime -> String) -> Value -> Value+enrichPrettyDate f v = withPrettyDate (T.pack . f . viewPostTime $ v) v --- Add both "next" and "previous" fields using `withPostNext` and `withPostPrevious`+-- | Assuming a "tags" field, enrich using withTagLinks.+enrichTagLinks :: (Text -> Text) -> Value -> Value+enrichTagLinks f v = withTagLinks ((`genLinkData` f) <$> viewTags v) v++-- | Assuming a "content" field with a spitter section, enrich using withTeaser+enrichTeaser :: Text -> Value -> Value+enrichTeaser s v = withTeaser (head (T.splitOn s (viewContent v))) v++-- | Add both "next" and "previous" fields using `withPostNext` and `withPostPrevious` extendNextPrevious :: Zipper [] Value -> Zipper [] Value extendNextPrevious = extendPrevious . extendNext --- Extend a Zipper of JSON Values to add "previous" objects.+-- | Extend a Zipper of JSON Values to add "previous" objects. extendPrevious :: Zipper [] Value -> Zipper [] Value extendPrevious = extend (liftA2 withPrevious zipperPreviousMaybe extract) --- Extend a Zipper of JSON Values to add "next" objects.+-- | Extend a Zipper of JSON Values to add "next" objects. extendNext :: Zipper [] Value -> Zipper [] Value extendNext = extend (liftA2 withNext zipperNextMaybe extract) extendPageNeighbours :: Int -> Zipper [] Value -> Zipper [] Value extendPageNeighbours r = extend (liftA2 withPages (zipperWithin r) extract) ---- Assuming a "url" field, enrich via a baseURL-enrichFullUrl :: Text -> Value -> Value-enrichFullUrl base v = withFullUrl (base <> viewUrl v) v---- Assuming a "date" field, enrich using withPrettyDate and a format string.-enrichPrettyDate :: (UTCTime -> String) -> Value -> Value-enrichPrettyDate f v = withPrettyDate (T.pack . f . viewPostTime $ v) v---- Assuming a "tags" field, enrich using withTagLinks.-enrichTagLinks :: (Text -> Text) -> Value -> Value-enrichTagLinks f v = withTagLinks ((`genLinkData` f) <$> viewTags v) v---- Assuming a "content" field with a spitter section, enrich using withTeaser-enrichTeaser :: Text -> Value -> Value-enrichTeaser s v = withTeaser (head (T.splitOn s (viewContent v))) v---- Assuming a 'srcPath' field, enrich using withUrl using a typicalHTMLUrl-enrichTypicalUrl :: Value -> Value-enrichTypicalUrl v = withUrl (typicalHTMLUrl (viewSrcPath v)) v---- Typical Markdown to HTML path transformation, by dropping a directory and--- changing the extension.-typicalHTMLPath :: String -> String-typicalHTMLPath = dropDirectory1 . (-<.> "html")---- Typical URL transformation, dropping the first directory, chagnging the--- extension to "html", and adding a preslash.-typicalHTMLUrl :: Text -> Text-typicalHTMLUrl = T.pack . ("/" <>) . typicalHTMLPath . T.unpack---- Create link data object with fields "id" and "url" using an id and a function--- transforming an id into a url.+-- | 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 id f = object ["id" A..= String id, "url" A..= String (f id)]+genLinkData x f = object ["id" A..= String x, "url" A..= String (f x)] --- Filter a lists of posts by tag.+-- | Filter a lists of posts by tag. tagFilterPosts :: Text -> [Value] -> [Value] tagFilterPosts tag = filter (elem tag . viewTags) --- Sort a lists of posts by date.+-- | Sort a lists of posts by date. dateSortPosts :: [Value] -> [Value] dateSortPosts = sortOn (Down . viewPostTime) --- Check whether two posts were posted in the same month.+-- | Check whether two posts were posted in the same month. sameMonth :: UTCTime -> UTCTime -> Bool sameMonth a b = y1 == y2 && m1 == m2 where (y1, m1, _) = f a@@ -247,15 +197,15 @@ monthFilterPosts time = filter (sameMonth time . viewPostTime) --- Partition a list of posts by the month they were posted.+-- | Partition a list of posts by the month they were posted. partitionToMonths :: [Value] -> [[Value]] partitionToMonths = groupBy (on sameMonth viewPostTime) . dateSortPosts --- Create a blog navbar object for a posts section, with layers "toc1", "toc2", and "toc3".-genBlogNavbarData :: Text -- "Top level title, e.g "Blog"- -> Text -- Root page, e.g "/posts"- -> (UTCTime -> Text) -- Formatting function to a UTCTime to a title.- -> (UTCTime -> Text) -- Formatting function to convert a UTCTime to a URL link+-- | Create a blog navbar object for a posts section, with layers "toc1", "toc2", and "toc3".+genBlogNavbarData :: Text -- ^ "Top level title, e.g "Blog"+ -> Text -- ^ Root page, e.g "/posts"+ -> (UTCTime -> Text) -- ^ Formatting function to a UTCTime to a title.+ -> (UTCTime -> Text) -- ^ Formatting function to convert a UTCTime to a URL link -> [Value] -> Value genBlogNavbarData a b f g xs = object [ "toc1" A..= object [@@ -263,18 +213,27 @@ , "url" A..= String b , "toc2" A..= Array (V.fromList $ map toc2 (partitionToMonths xs)) ] ] where+ toc2 [] = object [] toc2 t@(x : _) = object [ "title" A..= String (f (viewPostTime x)) , "url" A..= String (g (viewPostTime x)) , "toc3" A..= Array (V.fromList t) ] --- Create a toc navbar object for a docs section, with layers "toc1", "toc2" and "toc3".+-- | Create a toc navbar object for a docs section, with layers "toc1", "toc2" and "toc3". genTocNavbarData :: Cofree [] Value -> Value genTocNavbarData (x :< xs) = object ["toc1" A..= [_Object . at "toc2" ?~ Array (V.fromList $ map toc2 xs) $ x]] where- toc2 (x :< xs) = (_Object . at "toc3" ?~ Array (V.fromList $ map extract xs)) x+ toc2 (y :< ys) = (_Object . at "toc3" ?~ Array (V.fromList $ map extract ys)) y -genPageData :: Text -> (Text -> Text) -> Zipper [] [Value] -> Value +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+++genIndexPageData :: [Value]+ -> Text+ -> (Text -> Text)+ -> Int+ -> Maybe (Zipper [] Value)+genIndexPageData xs g h n = extend (genPageData g h) <$> paginate n xs
src/Shakebook/Data.hs view
@@ -2,95 +2,190 @@ import Control.Comonad.Cofree import Control.Comonad.Store-import Control.Comonad.Store.Zipper+import Control.Lens hiding ((:<)) import Control.Monad.Extra-import Data.Aeson as A-import Development.Shake as S+import Data.Aeson as A+import Data.Aeson.Lens+import Development.Shake as S import Development.Shake.FilePath-import RIO hiding (view)+import RIO hiding (Lens', lens, view) import RIO.List-import qualified RIO.Text as T+import RIO.Partial+import qualified RIO.Text as T+import Shakebook.Aeson import Slick import Slick.Pandoc-import Shakebook.Conventions-import Shakebook.Zipper import Text.Pandoc.Options type ToC = Cofree [] String --- Get a JSON Value of Markdown Data with markdown body as "contents" field--- and the srcPath as "srcPath" field.-readMarkdownFile' :: ReaderOptions -> WriterOptions -> String -> Action Value-readMarkdownFile' readerOptions writerOptions srcPath = do- docContent <- readFile' srcPath- docData <- markdownToHTMLWithOpts readerOptions writerOptions . T.pack $ docContent- return $ withSrcPath (T.pack srcPath) docData+data SbConfig = SbConfig+ { sbSrcDir :: FilePath+ , sbOutDir :: FilePath+ , sbBaseUrl :: Text+ , sbMdRead :: ReaderOptions+ , sbHTWrite :: WriterOptions+ , sbPPP :: Int+ }+ deriving (Show) +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 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)++-- | Add "srcPath" field based on input Text.+withSrcPath :: Text -> Value -> Value+withSrcPath = withStringField "srcPath"++-- | Add "baseUrl" field from input Text.+withBaseUrl :: Text -> Value -> Value+withBaseUrl = withStringField "baseUrl"++-- | Add "fullUrl" field from input Text.+withFullUrl :: Text -> Value -> Value+withFullUrl = withStringField "fullUrl"++-- | View the "url" field of a JSON Value.+viewUrl :: Value -> Text+viewUrl = view (key "url" . _String)++-- | Add "url" field from input Text.+withUrl :: Text -> Value -> Value+withUrl = withStringField "url"++-- | Assuming a "url" field, enrich via a baseURL+enrichFullUrl :: Text -> Value -> Value+enrichFullUrl base v = withFullUrl (base <> viewUrl v) v++-- | Assuming a 'srcPath' field, enrich using withUrl using a Text -> Text transformation.+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++typicalFullOutHTMLToMdSrcPath :: MonadShakebook r m => m (String -> String)+typicalFullOutHTMLToMdSrcPath = liftA2 (.) (pure (-<.> "md")) typicalFullOutToSrcPath++typicalMdSrcPathToHTMLFullOut :: MonadShakebook r m => m (String -> String)+typicalMdSrcPathToHTMLFullOut = view sbConfigL >>= \SbConfig{..} -> pure $+ (-<.> "html") . (sbOutDir </>) . drop 1 . fromJust . stripPrefix sbSrcDir++typicalSrcPathToUrl :: Text -> Text+typicalSrcPathToUrl = ("/" <>) . T.pack . (-<.> "html") . T.unpack++typicalUrlEnricher :: Value -> Value+typicalUrlEnricher v = withUrl (typicalSrcPathToUrl . viewSrcPath $ v) 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)) -getDirectoryMarkdown :: ReaderOptions -> WriterOptions -> FilePath -> [FilePattern] -> Action [Value]-getDirectoryMarkdown readOpts writeOpts dir pat = do- getDirectoryFiles dir pat >>= mapM (readMarkdownFile' readOpts writeOpts . (dir </>))--getEnrichedMarkdown :: ReaderOptions -> WriterOptions -> (Value -> Value) -> FilePath -> [FilePattern] -> Action [Value]-getEnrichedMarkdown readOpts writeOpts f dir pat = fmap f <$> getDirectoryMarkdown readOpts writeOpts dir pat+getMarkdown :: MonadShakebookAction r m => [FilePattern] -> m [Value]+getMarkdown pat = view sbConfigL >>= \SbConfig{..} ->+ liftAction (getDirectoryFiles sbSrcDir pat) >>= mapM readMarkdownFile' -genBuildPageAction :: FilePath -- The HTML template- -> (FilePath -> Action Value) -- How to get an initial markdown JSON Object from the out filepath.- -> (Value -> Value) -- Additional modifiers for the value- -> FilePath -- The out filepath - -> Action Value+{-| + 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 = do- pageT <- compileTemplate' template- dataT <- withData <$> getData out+ logInfo $ displayShow $ "Generating page with fullpath " <> out+ pageT <- liftAction $ compileTemplate' template+ dataT <- withData . typicalUrlEnricher <$> getData out+ logDebug $ displayShow dataT writeFile' out . T.unpack $ substitute pageT dataT return dataT -genIndexPageData :: [Value]- -> Text- -> (Text -> Text)- -> Int- -> Maybe (Zipper [] Value)-genIndexPageData xs g h n = fmap (extend (genPageData g h)) $ paginate n xs- traverseToSnd :: Functor f => (a -> f b) -> a -> f (a, b) traverseToSnd f a = (a,) <$> f a lower :: Cofree [] Value -> [Value] lower (_ :< xs) = extract <$> xs -data SbConfig = SbConfig {- sbSrcDir :: FilePath-, sbOutDir :: FilePath-, sbBaseUrl :: Text-, sbMdRead :: ReaderOptions-, sbHTWrite :: WriterOptions-, sbPPP :: Int-} deriving (Show)--newtype Shakebook a = Shakebook ( ReaderT SbConfig Rules a )- deriving (Functor, Applicative, Monad, MonadReader SbConfig)--newtype ShakebookA a = ShakebookA ( ReaderT SbConfig Action a )- deriving (Functor, Applicative, Monad, MonadReader SbConfig)--runShakebook :: SbConfig -> Shakebook a -> Rules a-runShakebook c (Shakebook f) = runReaderT f c--runShakebookA :: SbConfig -> ShakebookA a -> Action a-runShakebookA c (ShakebookA f) = runReaderT f c---loadSortFilterEnrich :: Ord b => [FilePattern] -- Filepattern- -> (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.- -> ShakebookA [(String, Value)]-loadSortFilterEnrich pat s f e = ShakebookA $ ask >>= \SbConfig {..} -> lift $ do- allPosts <- getDirectoryFiles sbSrcDir $ map (-<.> ".md") pat- readPosts <- sequence $ traverseToSnd (readMarkdownFile' sbMdRead sbHTWrite . (sbSrcDir </>)) <$> allPosts- return $ fmap (second e) $ sortOn (s . snd) $ filter (f . snd) $ readPosts+{-|+ 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 [(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 -loadSortEnrich :: Ord b => [FilePattern] -> (Value -> b) -> (Value -> Value) -> ShakebookA [(String, Value)]-loadSortEnrich pat s e = loadSortFilterEnrich pat s (const True) 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.+loadSortEnrich pat s = loadSortFilterEnrich pat s (const True)
src/Shakebook/Defaults.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-} module Shakebook.Defaults where import Control.Comonad@@ -6,24 +7,24 @@ import Control.Comonad.Store.Class import Control.Comonad.Store.Zipper import Control.Monad.Extra-import Data.Aeson as A+import Data.Aeson as A import Data.List.Split import Data.Text.Time-import Development.Shake as S+import Development.Shake as S import Development.Shake.Classes import Development.Shake.FilePath-import RIO hiding (view)-import qualified RIO.ByteString.Lazy as LBS+import RIO+import qualified RIO.ByteString.Lazy as LBS import RIO.List import RIO.List.Partial-import qualified RIO.Map as M+import qualified RIO.Map as M import RIO.Partial-import qualified RIO.Text as T+import qualified RIO.Text as T import RIO.Time import Shakebook.Aeson+import Shakebook.Conventions import Shakebook.Data import Shakebook.Rules-import Shakebook.Conventions import Shakebook.Zipper import Text.DocTemplates import Text.Pandoc.Class@@ -35,91 +36,112 @@ import Text.Pandoc.Walk import Text.Pandoc.Writers -monthURLFormat :: UTCTime -> String-monthURLFormat = formatTime defaultTimeLocale "%Y-%m"--prettyMonthFormat :: UTCTime -> String-prettyMonthFormat = formatTime defaultTimeLocale "%B, %Y"+defaultMonthURLFormat :: UTCTime -> String+defaultMonthURLFormat = formatTime defaultTimeLocale "%Y-%m" -prettyTimeFormat :: UTCTime -> String-prettyTimeFormat = formatTime defaultTimeLocale "%A, %B %d, %Y"+defaultPrettyMonthFormat :: UTCTime -> String+defaultPrettyMonthFormat = formatTime defaultTimeLocale "%B, %Y" -monthIndexUrlFormat :: UTCTime -> String-monthIndexUrlFormat t = "/posts/months" </> monthURLFormat t+defaultPrettyTimeFormat :: UTCTime -> String+defaultPrettyTimeFormat = formatTime defaultTimeLocale "%A, %B %d, %Y" -enrichPost :: Value -> Value-enrichPost = enrichTeaser "<!--more-->"- . enrichTagLinks ("/posts/tags/" <>)- . enrichPrettyDate prettyTimeFormat- . enrichTypicalUrl+defaultMonthIndexUrlFormat :: UTCTime -> String+defaultMonthIndexUrlFormat t = "/posts/months" </> defaultMonthURLFormat t ---Data models-------------------------------------------------------------------+defaultEnrichPost :: Value -> Value+defaultEnrichPost = enrichTeaser "<!--more-->"+ . enrichTagLinks ("/posts/tags/" <>)+ . enrichPrettyDate defaultPrettyTimeFormat -markdownReaderOptions :: ReaderOptions-markdownReaderOptions = def { readerExtensions = pandocExtensions }+defaultMarkdownReaderOptions :: ReaderOptions+defaultMarkdownReaderOptions = def { readerExtensions = pandocExtensions } -html5WriterOptions :: WriterOptions-html5WriterOptions = def { writerHTMLMathMethod = MathJax ""}+defaultHtml5WriterOptions :: WriterOptions+defaultHtml5WriterOptions = def { writerHTMLMathMethod = MathJax ""} -latexWriterOptions :: WriterOptions-latexWriterOptions = def { writerTableOfContents = True+defaultLatexWriterOptions :: WriterOptions+defaultLatexWriterOptions = def { writerTableOfContents = True , writerVariables = Context $ M.fromList [ ("geometry", SimpleVal "margin=3cm") , ("fontsize", SimpleVal "10") , ("linkcolor",SimpleVal "blue")] } -makePDFLaTeX :: Pandoc -> PandocIO (Either LBS.ByteString LBS.ByteString)-makePDFLaTeX p = do- t <- compileDefaultTemplate "latex"- makePDF "pdflatex" [] writeLaTeX latexWriterOptions { writerTemplate = Just t } p+defaultSbConfig :: Text -- ^ BaseURL+ -> SbConfig+defaultSbConfig x = SbConfig "site" "public" x defaultMarkdownReaderOptions defaultHtml5WriterOptions 5 -handleImages :: (Text -> Text) -> Inline -> Inline-handleImages 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+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 -handleHeaders :: Int -> Block -> Block-handleHeaders i (Header a as xs) = Header (max 1 (a + i)) as xs-handleHeaders _ x = 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 -pushHeaders :: Int -> Cofree [] Pandoc -> Cofree [] Pandoc-pushHeaders i (x :< xs) = walk (handleHeaders i) x :< map (pushHeaders (i+1)) xs -defaultDocsPatterns :: Cofree [] FilePath -- Rosetree Table of Contents.++defaultDocsPatterns :: MonadShakebookRules r m+ => Cofree [] FilePath -- Rosetree Table of Contents. -> FilePath -> (Value -> Value) -- Extra data modifiers.- -> Shakebook ()-defaultDocsPatterns toc tmpl withData = Shakebook $ ask >>= \SbConfig {..} -> do- let r = readMarkdownFile' sbMdRead sbHTWrite- lift $ cofreeRuleGen toc ((sbOutDir </>) . (-<.> ".html")) (- \xs -> \out -> do - ys <- mapM r (fmap (sbSrcDir </>) toc)- zs <- mapM r (fmap (sbSrcDir </>) xs)+ -> m ()+defaultDocsPatterns toc tmpl withData = ask >>= \r -> view sbConfigL >>= \SbConfig {..} -> do+ let e = typicalUrlEnricher+ m <- typicalFullOutHTMLToMdSrcPath+ liftRules $ cofreeRuleGen toc ((sbOutDir </>) . (-<.> ".html")) (+ \xs -> \out -> runShakebookA r $ do+ ys <- mapM readMarkdownFile' toc+ zs <- mapM readMarkdownFile' xs void $ genBuildPageAction (sbSrcDir </> tmpl)- (loadIfExists r . (-<.> ".md") . (sbSrcDir </>) . dropDirectory1)- (withData . withJSON (genTocNavbarData (fmap enrichTypicalUrl ys)) . withSubsections (lower (enrichTypicalUrl <$> zs)))+ (readMarkdownFile' . m)+ (withData+ . withJSON (genTocNavbarData (e <$> ys))+ . withSubsections (lower (e <$> zs))) out) -defaultPostIndexData :: [FilePattern] -> (a -> Value -> Bool) -> (a -> Text) -> (a -> Text -> Text) -> a -> ShakebookA (Zipper [] Value)-defaultPostIndexData pat f t l a = ask >>= \SbConfig {..} -> do- xs <- loadSortFilterEnrich pat (Down . viewPostTime) (f a) enrichPost+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 let ys = genIndexPageData (snd <$> xs) (t a) (l a) sbPPP return $ fromJust $ ys -defaultPagerPattern :: FilePattern+defaultPagerPattern :: MonadShakebookRules r m+ => FilePattern -> FilePath- -> (FilePattern -> Int)- -> (FilePattern -> a)- -> (a -> ShakebookA (Zipper [] Value))- -> (Zipper [] Value -> ShakebookA (Zipper [] Value))- -> Shakebook ()-defaultPagerPattern fp tmpl f g h w = Shakebook $ ask >>= \x@SbConfig{..} -> lift $- comonadStoreRuleGen (sbOutDir </> fp) (f . dropDirectory1) (g . dropDirectory1) (runShakebookA x . (w <=< h))- (\a -> void <$> genBuildPageAction (sbSrcDir </> tmpl) (const $ return a) id)+ -> (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))+ -> 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 (sbSrcDir </> tmpl) (const $ return a) id) -defaultPostIndexPatterns :: [FilePattern] -> FilePath -> (Zipper [] Value -> ShakebookA (Zipper [] Value)) -> Shakebook ()+defaultPostIndexPatterns :: MonadShakebookRules r m+ => [FilePattern]+ -> FilePath+ -> (Zipper [] Value -> ShakebookA r (Zipper [] Value)) -- ^ Pager extension.+ -> m () defaultPostIndexPatterns pat tmpl extData = do defaultPagerPattern "posts/index.html" tmpl (const 0)@@ -136,7 +158,11 @@ (const ("/posts/pages/" <>))) extData -defaultTagIndexPatterns :: [FilePattern] -> FilePath -> (Zipper [] Value -> ShakebookA (Zipper [] Value)) -> Shakebook ()+defaultTagIndexPatterns :: MonadShakebookRules r m+ => [FilePattern]+ -> FilePath+ -> (Zipper [] Value -> ShakebookA r (Zipper [] Value)) -- ^ Pager extension.+ -> m () defaultTagIndexPatterns pat tmpl extData = do defaultPagerPattern ("posts/tags/*/index.html") tmpl (const 0)@@ -147,45 +173,77 @@ extData defaultPagerPattern ("posts/tags/*/pages/*/index.html") tmpl ((+ (-1)) . read . (!! 4) . splitOn "/")- (T.pack . (!! 2) . splitOn "/") + (T.pack . (!! 2) . splitOn "/") (defaultPostIndexData pat (\x y -> elem x (viewTags y)) ("Posts tagged " <>) (\x y -> ("/posts/tags/" <> x <> "/pages/" <> y))) extData -defaultMonthIndexPatterns :: [FilePattern] -> FilePath -> (Zipper [] Value -> ShakebookA (Zipper [] Value)) -> Shakebook ()+defaultMonthIndexPatterns :: MonadShakebookRules r m+ => [FilePattern]+ -> FilePath+ -> (Zipper [] Value -> ShakebookA 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 . prettyMonthFormat)- (\x y -> ("/posts/months/" <> T.pack (monthURLFormat x) <> "/pages" <> 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 . prettyMonthFormat)- (\x y -> ("/posts/months/" <> T.pack (monthURLFormat x) <> "/pages" <> y)))+ (("Posts from " <>) . T.pack . defaultPrettyMonthFormat)+ (\x y -> ("/posts/months/" <> T.pack (defaultMonthURLFormat x) <> "/pages" <> y))) extData -defaultPostsPatterns :: FilePattern -> FilePath -> (Zipper [] Value -> ShakebookA (Zipper [] Value)) -> Shakebook ()-defaultPostsPatterns pat tmpl extData = Shakebook $ ask >>= \sbc@(SbConfig {..}) -> lift $- sbOutDir </> pat %> \out -> do- sortedPosts <- runShakebookA sbc $ loadSortEnrich [pat] (Down . viewPostTime) enrichPost- let i = (-<.> ".md") . dropDirectory1 $ out- let k = fromJust $ elemIndex i (fst <$> sortedPosts)- let z = fromJust $ seek k <$> zipper (snd <$> sortedPosts)- void $ genBuildPageAction (sbSrcDir </> tmpl)- (const $ runShakebookA sbc $ extract <$> extData z)- id out- +{-|+ Default Posts Pager. +-}+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.+ -> 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 (sbSrcDir </> tmpl)+ (const $ extract <$> extData z)+ id out -buildPDF :: Cofree [] String -> String -> FilePath -> ShakebookA ()-buildPDF toc meta out = ShakebookA $ ask >>= \SbConfig {..} -> lift $ do+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)) =+ if T.takeEnd 4 src == ".mp4" then Str (f src)+ else Image attr ins ("public/" <> 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++-- | 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 Right f <- liftIO . runIOorExplode $ do@@ -195,52 +253,84 @@ makePDFLaTeX z LBS.writeFile out f -defaultSinglePagePattern :: FilePath -- The output filename e.g "index.html".- -> FilePath -- A tmpl file.- -> (Value -> ShakebookA Value) -- Last minute enrichment.- -> Shakebook ()-defaultSinglePagePattern out tmpl withDataM = Shakebook $ ask >>= \sbc@(SbConfig {..}) -> lift $- sbOutDir </> out %> void . genBuildPageAction- (sbSrcDir </> tmpl)+{-|+ 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 :: MonadShakebookRules r m+ => FilePath -- ^ The output filename e.g "index.html".+ -> FilePath -- ^ A tmpl file.+ -> (Value -> ShakebookA 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' sbMdRead sbHTWrite . (-<.> ".md") . (sbSrcDir </>) . dropDirectory1 $ fp- runShakebookA sbc $ withDataM x)+ x <- readMarkdownFile' . m $ fp+ withDataM $ x) id -defaultStaticsPatterns :: [FilePattern] -> Shakebook ()-defaultStaticsPatterns xs = Shakebook $ ask >>= \SbConfig {..} -> lift $- mconcat $ map (\x -> sbOutDir </> x %> \y -> copyFileChanged ((sbSrcDir </>) . dropDirectory1 $ y) y) xs+{-|+ 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 <- typicalFullOutToSrcPath+ liftRules $ mconcat $ map (\x -> sbOutDir </> x %> \y -> copyFileChanged (f y) y) xs -defaultCleanPhony :: Shakebook ()-defaultCleanPhony = Shakebook $ ask >>= \SbConfig {..} -> lift $+-- | Default "shake clean" phony, cleans your output directory.+defaultCleanPhony :: MonadShakebookRules r m => m ()+defaultCleanPhony = view sbConfigL >>= \SbConfig {..} -> liftRules $ phony "clean" $ do putInfo $ "Cleaning files in " ++ sbOutDir removeFilesAfter sbOutDir ["//*"] -defaultStaticsPhony :: Shakebook ()-defaultStaticsPhony = Shakebook $ ask >>= \SbConfig {..} -> lift $+{-|+ 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] -defaultPostsPhony :: [FilePattern] -> Shakebook ()-defaultPostsPhony pattern = Shakebook $ ask >>= \SbConfig {..} -> lift $+{-|+ 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] -defaultPostIndexPhony :: [FilePattern] -> Shakebook ()-defaultPostIndexPhony pattern = Shakebook $ ask >>= \SbConfig {..} -> lift $+{-|+ 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 $ phony "posts-index" $ do- fp <- getDirectoryMarkdown sbMdRead sbHTWrite sbSrcDir pattern+ 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)]] -defaultTagIndexPhony :: [FilePattern] -> Shakebook ()-defaultTagIndexPhony pattern = Shakebook $ ask >>= \SbConfig {..} -> lift $+{-|+ 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 = ask >>= \r -> view sbConfigL >>= \SbConfig {..} -> liftRules $ phony "tag-index" $ do- fp <- getDirectoryMarkdown sbMdRead sbHTWrite sbSrcDir pattern+ 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"@@ -248,19 +338,28 @@ , p <- [1..size (fromJust $ paginate sbPPP $ tagFilterPosts x fp)] ] -defaultMonthIndexPhony :: [FilePattern] -> Shakebook ()-defaultMonthIndexPhony pattern = Shakebook $ ask >>= \SbConfig {..} -> lift $+{-|+ 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 <- getDirectoryMarkdown sbMdRead sbHTWrite sbSrcDir pattern+ fp <- runShakebookA r $ getMarkdown pattern let times = viewAllPostTimes fp- need [sbOutDir </> "posts/months" </> monthURLFormat t </> "index.html" | t <- times]- need [sbOutDir </> "posts/months" </> monthURLFormat t </> "pages" </> show p </> "index.html"+ 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)] ] -defaultDocsPhony :: Cofree [] String -> Shakebook ()-defaultDocsPhony toc = Shakebook $ ask >>= \SbConfig {..} -> lift $+-- | 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 {..} -> liftRules $ phony "docs" $ do- fp <- getDirectoryFiles sbSrcDir (foldr ((<>) . pure) [] toc)- need $ [ (sbOutDir </>) . (-<.> ".html") $ x | x <- fp]+ let xs = (foldr ((<>) . pure) [] toc)+ need $ [ (sbOutDir </>) . (-<.> ".html") $ x | x <- xs]
src/Shakebook/Feed.hs view
@@ -3,15 +3,16 @@ , buildFeed ) where -import Data.Aeson-import Development.Shake-import RIO-import RIO.List.Partial-import Shakebook.Conventions-import qualified RIO.Text as T-import qualified RIO.Text.Lazy as TL-import Text.Atom.Feed as Atom-import Text.Atom.Feed.Export+import Data.Aeson+import Development.Shake+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 asAtomEntry :: Value -> Atom.Entry@@ -23,5 +24,6 @@ buildFeed title baseUrl xs out = do let fs = asAtomEntry <$> dateSortPosts xs let t = Atom.nullFeed baseUrl (Atom.TextString title) $ Atom.entryUpdated (head fs)- let (Just a) = textFeed (t { Atom.feedEntries = fs })- writeFile' out (T.unpack . TL.toStrict $ a)+ case textFeed (t { Atom.feedEntries = fs }) of+ Just a -> writeFile' out (T.unpack . TL.toStrict $ a)+ Nothing -> return ()
src/Shakebook/Rules.hs view
@@ -2,25 +2,31 @@ import Control.Comonad.Cofree import Control.Comonad.Store-import RIO 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.+ => 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 = do+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- -> (FilePath -> FilePath)- -> (w FilePath -> FilePath -> Action ())+ => w FilePath -- ^ A cofree comonad of FilePaths+ -> (FilePath -> FilePath) -- ^ How to find the source for each out 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
src/Shakebook/Zipper.hs view
@@ -7,10 +7,10 @@ , zipperWithin ) where -import Control.Comonad.Store-import Control.Comonad.Store.Zipper-import Data.List.Split-import RIO+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])
test/Spec.hs view
@@ -1,2 +1,106 @@+import Control.Comonad.Cofree+import Control.Comonad.Store.Zipper+import Data.Aeson+import Data.List.Split+import Development.Shake+import RIO+import RIO.List+import qualified RIO.Text as T+import Shakebook+import Shakebook.Aeson+import Shakebook.Conventions+import Shakebook.Defaults+import Test.Tasty+import Test.Tasty.Golden+import Text.Pandoc.Highlighting++srcDir :: String+srcDir = "test/site"++outDir :: String+outDir = "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" :< []+ ]+ ]++myBlogNavbar :: [Value] -> Value+myBlogNavbar = genBlogNavbarData "Blog" "/posts/" (T.pack . defaultPrettyMonthFormat) (T.pack . defaultMonthIndexUrlFormat)++numRecentPosts :: Int+numRecentPosts = 3++numPageNeighbours :: Int+numPageNeighbours = 1++sbc :: SbConfig+sbc = SbConfig srcDir outDir baseUrl defaultMarkdownReaderOptions defaultHtml5WriterOptions 5++extendPostsZipper :: MonadShakebookAction r m => Zipper [] Value -> m (Zipper [] Value)+extendPostsZipper = return++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 :: MonadShakebookRules r m => m ()+rules = do+ defaultSinglePagePattern "index.html" "templates/index.html"+ (affixRecentPosts ["posts/*.md"] numRecentPosts defaultEnrichPost)++ defaultPostsPatterns "posts/*.html" "templates/post.html"+ (affixBlogNavbar ["posts/*.md"] "Blog" "/posts/" (T.pack . defaultPrettyMonthFormat) (T.pack . defaultMonthIndexUrlFormat) defaultEnrichPost+ <=< affixRecentPosts ["posts/*.md"] numRecentPosts defaultEnrichPost+ . defaultEnrichPost . withHighlighting pygments)+ extendPostsZipper++ defaultDocsPatterns toc "templates/docs.html"+ (withHighlighting pygments)++ defaultPostIndexPatterns ["posts/*.md"] "templates/post-list.html"+ (enrichPostIndexPage ["posts/*.md"])++ defaultTagIndexPatterns ["posts/*.md"] "templates/post-list.html"+ (enrichPostIndexPage ["posts/*.md"])++ defaultMonthIndexPatterns ["posts/*.md"] "templates/post-list.html"+ (enrichPostIndexPage ["posts/*.md"])+ defaultStaticsPatterns ["css//*", "images//*", "js//*", "webfonts//*"]+ defaultStaticsPhony++ defaultPostsPhony ["posts/*.md"]+ defaultPostIndexPhony ["posts/*.md"]++ defaultTagIndexPhony ["posts/*.md"]++ defaultMonthIndexPhony ["posts/*.md"]++ defaultDocsPhony toc+ defaultCleanPhony++tests :: [FilePath] -> TestTree+tests xs = testGroup "Rendering Tests" $+ map ( \x -> goldenVsFile x x+ (replace "golden" "public" x)+ (return ())) xs+ where replace from to' = intercalate to' . splitOn from+ main :: IO ()-main = putStrLn "Test suite not yet implemented"+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"] >> runShakebook f rules+ shake shakeOptions $ want ["docs", "month-index", "posts-index", "tag-index", "posts"] >> runShakebook f rules+ defaultMain $ tests xs+ snd lf