diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # Changelog for Shakebook +## (v0.5.0.0) + +* Upgrade to [shake-plus](https://hackage.haskell.org/package/shake-plus) v0.1.6.0. +* Drop `enrichFullUrl`, `enrichUrl` and `enrichSupposedUrl`. +* Drop `immediateShoots`. +* Drop dependency on `extra`. +* Remove `withXExtension` function and Depend on new library [path-extensions](https://hackage.haskell.org/package/path-extensions). +* Re-export `Development.Shake.Plus` and `Data.Aeson` +* Re-expot most `Shakebook` submodules. +* Re-export Text.Pandoc.Highlighting + ## (v0.4.0.0) * Remove `SBConfig` and constraints from this library. This was only here for refactoring diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,8 @@ # Shakebook - Static Site & Technical Documentation Generator Shakebook is a collection of data handlers, shake rules and useful conventions -for generating technical documentation and blogs. This is the API library. For -a running example see http://shakebook.site. +for generating technical documentation and blogs. This is the API library. + +To get started you can use the template repository at http://gitlab.com/shakebook-template/shakebook-template + +For full documentation see http://shakebook.site. diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# 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 Text.Pandoc.Options -import Within - -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 - } - -data BuildOpts = BuildOpts - { sbSrcDir :: Path Rel Dir - , sbOutDir :: Path Rel Dir - , sbBaseUrl :: Text - , sbMdRead :: ReaderOptions - , sbHtWrite :: WriterOptions - , sbPPP :: Int - } -data AppConfig = AppConfig - { _opts :: BuildOpts - , _lf :: LogFunc - } - -class HasBuildOpts a where - buildOptsL :: Lens' a BuildOpts - -instance HasLogFunc AppConfig where - logFuncL = lens _lf undefined - -instance HasBuildOpts AppConfig where - buildOptsL = lens _opts undefined - -opts :: ParserInfo SimpleOpts -opts = info (sample <**> helper) - ( fullDesc - <> 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 - s' <- parseRelDir (srcDir x) - o' <- parseRelDir (outDir x) - app $ BuildOpts s' o' (T.pack $ baseUrl x) defaultMarkdownReaderOptions defaultHtml5WriterOptions (ppp x) - -app :: BuildOpts -> IO () -app sbc = do - logOptions' <- logOptionsHandle stdout True - lf <- newLogFunc logOptions' - let f = AppConfig sbc (fst lf) - - shake shakeOptions $ do - - want ["all"] - - runShakePlus f $ do - BuildOpts{..} <- view buildOptsL - - readMDC <- newCache $ loadMarkdownAsJSON sbMdRead sbHtWrite - - postsC <- newCache $ \w -> do - xs <- batchLoadWithin' w readMDC - return $ defaultEnrichPost <$> xs - - 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"] - - snd lf diff --git a/shakebook.cabal b/shakebook.cabal --- a/shakebook.cabal +++ b/shakebook.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.33.1. -- -- see: https://github.com/sol/hpack -- --- hash: 468c86683bdf3cc44a2aaa53465f140ee14fe822330207c10c6e16febcbd3b35 +-- hash: 166b471f6106f0f5cbd0ce94e44b3042fb7f4d1b5da4deed5e14c7aea3195b8c name: shakebook -version: 0.4.0.0 +version: 0.5.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 @@ -43,63 +43,24 @@ , comonad , comonad-extras , doctemplates - , extra , feed , free + , ixset-typed , lens , lens-aeson , mustache , pandoc , pandoc-types - , path + , path-extensions , relude , rio - , shake , shake-plus , slick , split , text-time - , within , zipper-extra 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 - , aeson-with - , base >=4.7 && <5 - , comonad - , comonad-extras - , doctemplates - , extra - , feed - , free - , lens - , lens-aeson - , mustache - , optparse-applicative - , pandoc - , pandoc-types - , path - , relude - , rio - , shake - , shake-plus - , shakebook - , slick - , split - , text-time - , within - , zipper-extra - default-language: Haskell2010 - test-suite shakebook-test type: exitcode-stdio-1.0 main-is: Spec.hs @@ -116,18 +77,18 @@ , comonad , comonad-extras , doctemplates - , extra , feed , free + , hashable-time + , ixset-typed , lens , lens-aeson , mustache , pandoc , pandoc-types - , path + , path-extensions , relude , rio - , shake , shake-plus , shakebook , slick @@ -135,6 +96,5 @@ , tasty , tasty-golden , text-time - , within , zipper-extra default-language: Haskell2010 diff --git a/src/Shakebook.hs b/src/Shakebook.hs --- a/src/Shakebook.hs +++ b/src/Shakebook.hs @@ -1,6 +1,29 @@ module Shakebook ( - - module Shakebook.Data + module Control.Comonad.Cofree +, module Control.Comonad.Store +, module Control.Comonad.Store.Zipper +, module Control.Comonad.Zipper.Extra +, module Data.Aeson +, module Development.Shake.Plus +, module Shakebook.Conventions +, module Shakebook.Data +, module Shakebook.Defaults +, module Shakebook.Feed +, module Shakebook.Mustache +, module Shakebook.Pandoc +, module Text.Pandoc.Highlighting ) where +import Control.Comonad.Cofree +import Control.Comonad.Store +import Control.Comonad.Store.Zipper +import Control.Comonad.Zipper.Extra +import Data.Aeson +import Development.Shake.Plus +import Shakebook.Conventions import Shakebook.Data +import Shakebook.Defaults +import Shakebook.Feed +import Shakebook.Mustache +import Shakebook.Pandoc +import Text.Pandoc.Highlighting diff --git a/src/Shakebook/Conventions.hs b/src/Shakebook/Conventions.hs --- a/src/Shakebook/Conventions.hs +++ b/src/Shakebook/Conventions.hs @@ -53,7 +53,6 @@ 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 @@ -165,14 +164,15 @@ extendNextPrevious :: Zipper [] Value -> Zipper [] Value extendNextPrevious = extendPrevious . extendNext --- | Extend a Zipper of JSON Values to add "previous" objects. +-- | Extend a Zipper of 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 Values to add "next" objects. extendNext :: Zipper [] Value -> Zipper [] Value extendNext = extend (liftA2 withNext zipperNextMaybe extract) +-- | Extend a Zipper of Values to add list of "pages" within r hops either side of the focus. extendPageNeighbours :: Int -> Zipper [] Value -> Zipper [] Value extendPageNeighbours r = extend (liftA2 withPages (zipperWithin r) extract) diff --git a/src/Shakebook/Data.hs b/src/Shakebook/Data.hs --- a/src/Shakebook/Data.hs +++ b/src/Shakebook/Data.hs @@ -2,19 +2,16 @@ module Shakebook.Data where import Control.Comonad.Env as E -import Control.Comonad.Cofree 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 Path as P +import Path.Extensions import RIO hiding (Lens', lens, view) import qualified RIO.Text as T import Shakebook.Pandoc import Text.Pandoc -import Within newtype PathDisplay a t = PathDisplay (Path a t) @@ -23,10 +20,10 @@ newtype WithinDisplay a t = WithinDisplay (Within a t) -instance Display t => Display (WithinDisplay a t) where - display (WithinDisplay (WithinT (EnvT e (Identity a)))) = display (PathDisplay e) <> "[" <> display a <> "]" +instance Display (WithinDisplay a (Path b t)) where + display (WithinDisplay (WithinT (EnvT e (Identity a)))) = display (PathDisplay e) <> "[" <> display (PathDisplay a) <> "]" -instance Display t => Display [WithinDisplay a t] where +instance Display [WithinDisplay a (Path b t)] where display [] = "" display (x : xs) = display x <> " : " <> display xs @@ -74,35 +71,14 @@ 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 'src-path' field, enrich using withUrl using a Text -> Text transformation. -enrichUrl :: (Text -> Text) -> Value -> Value -enrichUrl f v = withUrl (f (viewSrcPath v)) v - -withHtmlExtension :: MonadThrow m => Path Rel File -> m (Path Rel File) -withHtmlExtension = replaceExtension ".html" - -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" - +-- | Add a leading slash to a `Path Rel File` to turn it into a url as `Text`. toGroundedUrl :: Path Rel File -> Text toGroundedUrl = T.pack . toFilePath . ($(mkAbsDir "/") ) +-- | Generate a "supposed" url, the grounded version of the markdown source path. generateSupposedUrl :: MonadThrow m => Path Rel File -> m Text generateSupposedUrl srcPath = toGroundedUrl <$> withHtmlExtension srcPath -enrichSupposedUrl :: MonadThrow m => Value -> m Value -enrichSupposedUrl v = do - x <- parseRelFile $ T.unpack $ viewSrcPath v - y <- generateSupposedUrl x - return $ withUrl y v - {-| Get a JSON Value of Markdown Data with markdown body as "contents" field and the srcPath as "srcPath" field. @@ -120,6 +96,3 @@ return $ withContent outText . withSrcPath (T.pack . toFilePath $ extract srcPath) . withUrl supposedUrl $ meta' - -immediateShoots :: Cofree [] a -> [a] -immediateShoots(_ :< xs) = extract <$> xs diff --git a/src/Shakebook/Defaults.hs b/src/Shakebook/Defaults.hs --- a/src/Shakebook/Defaults.hs +++ b/src/Shakebook/Defaults.hs @@ -2,11 +2,11 @@ module Shakebook.Defaults where import Data.Aeson as A +import Development.Shake.Plus import RIO import qualified RIO.Map as M import qualified RIO.Text as T import RIO.Time -import Path import Shakebook.Conventions import Text.DocTemplates import Text.Pandoc.Definition @@ -28,7 +28,6 @@ defaultEnrichPost = enrichTeaser "" . enrichTagLinks ("/posts/tags/" <>) . enrichPrettyDate defaultPrettyTimeFormat --- . enrichTypicalUrl defaultMarkdownReaderOptions :: ReaderOptions defaultMarkdownReaderOptions = def { readerExtensions = pandocExtensions } @@ -45,7 +44,7 @@ } defaultVideoReplacement :: Text -> Text -> Inline -defaultVideoReplacement baseUrl = \x -> Str $ "[Video available at [" <> baseUrl <> "/" <> x <> "]" +defaultVideoReplacement baseUrl x = Str $ "[Video available at [" <> baseUrl <> "/" <> x <> "]" defaultPagePaths :: MonadThrow m => [Int] -> m [Path Rel File] defaultPagePaths xs = do diff --git a/src/Shakebook/Feed.hs b/src/Shakebook/Feed.hs --- a/src/Shakebook/Feed.hs +++ b/src/Shakebook/Feed.hs @@ -5,7 +5,6 @@ import Data.Aeson import Development.Shake.Plus -import Path import RIO import RIO.List.Partial import qualified RIO.Text.Lazy as TL diff --git a/src/Shakebook/Mustache.hs b/src/Shakebook/Mustache.hs --- a/src/Shakebook/Mustache.hs +++ b/src/Shakebook/Mustache.hs @@ -12,20 +12,17 @@ , compileTemplate' ) where -import Data.Aeson -import Path -import RIO +import Data.Aeson +import Development.Shake.Plus +import RIO import qualified Slick.Mustache -import Development.Shake.Plus -import Text.Mustache -import Within +import Text.Mustache +-- | Lifted version of `Slick.Mustache.compileTemplate'` with well-typed `Path`. compileTemplate' :: MonadAction m => Path Rel File -> m Template compileTemplate' = liftAction . Slick.Mustache.compileTemplate' . toFilePath -{-| - Build a single page straight from a template. --} +-- | Build a single page straight from a template. buildPageAction :: MonadAction m => Path Rel File -- ^ The HTML templatate. -> Value -- ^ A JSON value. @@ -35,6 +32,7 @@ pageT <- compileTemplate' template writeFile' out $ substitute pageT value +-- | Like `buildPageAction`, but uses `Within` values. buildPageActionWithin :: MonadAction m => Within Rel (Path Rel File) -> Value diff --git a/src/Shakebook/Pandoc.hs b/src/Shakebook/Pandoc.hs --- a/src/Shakebook/Pandoc.hs +++ b/src/Shakebook/Pandoc.hs @@ -12,26 +12,24 @@ , flattenMeta ) where -import Control.Comonad.Cofree -import Data.Aeson -import Development.Shake.Plus -import RIO -import qualified RIO.ByteString.Lazy as LBS -import qualified RIO.Text as T -import Path +import Control.Comonad.Cofree +import Data.Aeson +import Development.Shake.Plus +import RIO +import qualified RIO.ByteString.Lazy as LBS +import qualified RIO.Text as T import qualified Slick.Pandoc -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 +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 -data PandocActionException = PandocActionException String - deriving (Show, Eq, Typeable) +newtype PandocActionException = PandocActionException String + deriving (Show, Eq, Typeable) instance Exception PandocActionException where displayException (PandocActionException s) = s @@ -57,10 +55,10 @@ -- | 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 + mapM parseRelFile (drop 1 . T.unpack <$> pullImages pdoc) >>= needIn outDir where pullImages = query f f (Image _ _ (src, _)) = [src] - f _ = [] + f _ = [] -- | Make a pdflatex in an `Action`. makePDFLaTeX :: (MonadAction m, MonadThrow m) => WriterOptions -> Pandoc -> m LBS.ByteString @@ -74,7 +72,7 @@ -- 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 +progressivelyDemoteHeaders = pushHeaders 0 where handleHeaders :: Int -> Block -> Block handleHeaders i (Header a as xs) = Header (max 1 (a + i)) as xs handleHeaders _ x = x @@ -83,16 +81,16 @@ 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 :: MonadThrow m => [String] -> (Text -> Inline) -> Pandoc -> m Pandoc replaceUnusableImages exts f = walkM handleImages where handleImages i@(Image _ _ (src, _)) = do x <- parseAbsFile (T.unpack src) >>= fileExtension - return $ if elem x exts then f src else i + return $ if x `elem` 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 (Image attr ins (src, txt)) = Image attr ins (T.pack (toFilePath dir) <> "/" <> src, txt) handleImages x = x flattenMeta :: MonadAction m => (Pandoc -> PandocIO Text) -> Meta -> m Value diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,29 +1,20 @@ {-# LANGUAGE TemplateHaskell #-} -import Control.Comonad.Cofree -import Control.Comonad.Store -import Control.Comonad.Store.Zipper -import Control.Comonad.Zipper.Extra -import Data.Aeson +import Control.Lens hiding ((:<)) import Data.Aeson.With +import Data.Hashable.Time() import Data.List.Split import Data.Text.Time -import Development.Shake.Plus -import Path +import Path.Extensions 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.Data -import Shakebook.Defaults -import Shakebook.Mustache -import Shakebook.Conventions +import Shakebook import Test.Tasty import Test.Tasty.Golden -import Text.Pandoc.Highlighting -import Within sourceFolder :: Path Rel Dir sourceFolder = $(mkRelDir "test/site") @@ -80,120 +71,150 @@ allPosts <- postsC fp return $ genBlogNavbarData "Blog" "/posts/" (T.pack . defaultPrettyMonthFormat) - (defaultMonthUrlFragment) (HM.elems allPosts) + defaultMonthUrlFragment (HM.elems allPosts) + postsZ <- newCache $ \fp -> do + xs <- sortedPosts fp + zs <- ifor xs $ \i (k, _) -> do + z <- zipper' (snd <$> xs) + return (k, seek i z) + return $ HM.fromList zs + + blogIndexPageData <- newCache $ \fp -> do + xs <- sortedPosts fp + genIndexPageData (snd <$> xs) "Posts" ("/posts/pages/" <>) postsPerPage + + blogTagIndexPageData <- newCache $ \fp -> do + xs <- sortedPosts fp + zs <- forM (viewAllPostTags (snd <$> xs)) $ \t -> do + let ys = filter (elem t . viewTags . snd) xs + k <- genIndexPageData (snd <$> ys) ("Posts tagged " <> t) (("/posts/tags/" <> t <> "/pages/") <>) postsPerPage + return (t, k) + return $ HM.fromList zs + + blogMonthIndexPageData <- newCache $ \fp -> do + xs <- sortedPosts fp + zs <- forM (nub $ defaultMonthUrlFormat <$> viewAllPostTimes (snd <$> xs)) $ \t -> do + let t' = parseISODateTime . T.pack $ t + let ys = filter (sameMonth t' . viewPostTime . snd) xs + k <- genIndexPageData (snd <$> ys) + (("Posts from " <>) . T.pack . defaultPrettyMonthFormat $ t') + (("/posts/months/" <> T.pack (defaultMonthUrlFormat t') <> "/pages/") <>) postsPerPage + return (t', k) + return $ HM.fromList zs + let myPosts = ["posts/*.md"] `within` sourceFolder + o' = (`within` outputFolder) + s' = (`within` sourceFolder) + myBuildPage tmpl v out = do rs <- getRecentPosts myPosts let v' = withHighlighting pygments . withSocialLinks mySocial . withSiteTitle siteTitle . withRecentPosts rs $ v - buildPageActionWithin (tmpl `within` sourceFolder) v' out + buildPageActionWithin (s' tmpl) v' out + myBuildBlogPage tmpl v out = do + k <- getBlogNavbar myPosts + myBuildPage tmpl (withJSON k v) out - ("index.html" `within` outputFolder) %^> \out -> do - src <- blinkAndMapM sourceFolder withMarkdownExtension $ out + myBuildPostListPage z out = do + let v = extract . extendPageNeighbours numPageNeighbours $ z + myBuildBlogPage $(mkRelFile "templates/post-list.html") v out + + o' "index.html" %^> \out -> do + src <- blinkAndMapM sourceFolder withMdExtension out v <- readMDC src myBuildPage $(mkRelFile "templates/index.html") v out - ("posts/*.html" `within` outputFolder) %^> \out -> do - src <- blinkAndMapM sourceFolder withMarkdownExtension $ out - xs <- sortedPosts myPosts - let k = elemIndex src (fst <$> xs) - let z = fromJust $ liftA2 seek k $ zipper (snd <$> xs) - n <- getBlogNavbar myPosts - let v' = withJSON n $ (extract z) - myBuildPage $(mkRelFile "templates/post.html") v' out + o' "posts/*.html" %^> \out -> do + src <- blinkAndMapM sourceFolder withMdExtension out + xs <- postsZ myPosts + case HM.lookup src xs of + Nothing -> logError $ "Attempting to lookup non-existent post " <> display (WithinDisplay src) + Just x -> myBuildBlogPage $(mkRelFile "templates/post.html") (extract x) out - toc' <- mapM (mapM withHtmlExtension) $ fmap (`within` outputFolder) tableOfContents - void . sequence . flip extend toc' $ \xs -> (fmap toFilePath $ extract xs) %^> \out -> do - let getDoc = readMDC <=< blinkAndMapM sourceFolder withMarkdownExtension + toc' <- mapM (mapM withHtmlExtension) $ fmap o' tableOfContents + void . sequence . flip extend toc' $ \xs -> (toFilePath <$> extract xs) %^> \out -> do + let getDoc = readMDC <=< blinkAndMapM sourceFolder withMdExtension ys <- mapM getDoc toc' - zs <- mapM getDoc $ (immediateShoots xs) - v <- getDoc $ out + zs <- mapM getDoc (fmap extract . unwrap $ xs) + v <- getDoc out let v' = withJSON (genTocNavbarData ys) . withSubsections zs $ v myBuildPage $(mkRelFile "templates/docs.html") v' out - ("posts/index.html" `within` outputFolder) %^> - copyFileChangedWithin ($(mkRelFile "posts/pages/1/index.html") `within` outputFolder) + o' "posts/index.html" %^> + copyFileChangedWithin (o' $(mkRelFile "posts/pages/1/index.html")) - ("posts/pages/*/index.html" `within` outputFolder) %^> \out -> do - xs <- sortedPosts myPosts + o' "posts/pages/*/index.html" %^> \out -> do let n = (+ (-1)) . read . (!! 2) . splitOn "/" . toFilePath . extract $ out - p <- seek n <$> genIndexPageData (snd <$> xs) "Posts" ("/posts/pages/" <>) postsPerPage - k <- getBlogNavbar myPosts - let v = withJSON k $ extract $ extendPageNeighbours numPageNeighbours p - myBuildPage $(mkRelFile "templates/post-list.html") v out + xs <- blogIndexPageData myPosts + myBuildPostListPage (seek n xs) out - ("posts/tags/*/index.html" `within` outputFolder) %^> \out -> do + o' "posts/tags/*/index.html" %^> \out -> do let t = (!! 2) . splitOn "/" . toFilePath . extract $ out i <- parseRelFile $ "posts/tags/" <> t <> "/pages/1/index.html" - copyFileChangedWithin (i `within` outputFolder) out + copyFileChangedWithin (o' i) out - ("posts/tags/*/pages/*/index.html" `within` outputFolder) %^> \out -> do - let t = T.pack . (!! 2) . splitOn "/" . toFilePath . extract $ out - xs <- filter (elem t . viewTags . snd) <$> sortedPosts myPosts - let n = (+ (-1)) . read . (!! 4) . splitOn "/" . toFilePath . extract $ out - p <- seek n <$> genIndexPageData (snd <$> xs) ("Posts tagged " <> t) (("/posts/tags/" <> t <> "/pages/") <>) postsPerPage - k <- getBlogNavbar myPosts - let v = withJSON k $ extract $ extendPageNeighbours numPageNeighbours p - myBuildPage $(mkRelFile "templates/post-list.html") v out + o' "posts/tags/*/pages/*/index.html" %^> \out -> do + let t = T.pack . (!! 2) . splitOn "/" . toFilePath . extract $ out + let n = (+ (-1)) . read . (!! 4) . splitOn "/" . toFilePath . extract $ out + xs <- blogTagIndexPageData myPosts + case HM.lookup t xs of + Nothing -> logError $ "Attempting to lookup non-existant tag " <> display t + Just x -> myBuildPostListPage (seek n x) out - ("posts/months/*/index.html" `within` outputFolder) %^> \out -> do + o' "posts/months/*/index.html" %^> \out -> do let t = (!! 2) . splitOn "/" . toFilePath . extract $ out i <- parseRelFile $ "posts/months/" <> t <> "/pages/1/index.html" - copyFileChangedWithin (i `within` outputFolder) out + copyFileChangedWithin (o' i) out - ("posts/months/*/pages/*/index.html" `within` outputFolder) %^> \out -> do - let t = parseISODateTime . T.pack . (!! 2) . splitOn "/" . toFilePath . extract $ out - xs <- filter (sameMonth t . viewPostTime . snd) <$> sortedPosts myPosts - let n = (+ (-1)) . read . (!! 4) . splitOn "/" . toFilePath . extract $ out - p <- seek n <$> genIndexPageData (snd <$> xs) - (("Posts from " <>) . T.pack . defaultPrettyMonthFormat $ t) - (("/posts/months/" <> T.pack (defaultMonthUrlFormat t) <> "/pages/") <>) postsPerPage - k <- getBlogNavbar myPosts - let v = withJSON k $ extract $ extendPageNeighbours numPageNeighbours p - myBuildPage $(mkRelFile "templates/post-list.html") v out + o' "posts/months/*/pages/*/index.html" %^> \out -> do + let t = parseISODateTime . T.pack . (!! 2) . splitOn "/" . toFilePath . extract $ out + let n = (+ (-1)) . read . (!! 4) . splitOn "/" . toFilePath . extract $ out + xs <- blogMonthIndexPageData myPosts + case HM.lookup t xs of + Nothing -> logError $ "Attempting to lookup non-existant month " <> displayShow t + Just x -> myBuildPostListPage (seek n x) out - phony "index" $ - needIn outputFolder [$(mkRelFile "index.html")] + o' ["css//*", "js//*", "webfonts//*", "images//*"] |%^> \out -> + copyFileChangedWithin (blinkLocalDir sourceFolder out) out + let simplePipeline f = getDirectoryFiles sourceFolder >=> mapM f >=> needIn outputFolder + verbatimPipeline = simplePipeline return + + phony "statics" $ verbatimPipeline ["css//*", "js//*", "webfonts//*", "images//*"] + + phony "index" $ needIn outputFolder [$(mkRelFile "index.html")] + phony "post-index" $ do - xs <- sortedPosts myPosts - ps <- paginate' postsPerPage xs - fs <- defaultPagePaths [1..size ps] - needIn (outputFolder $(mkRelDir "posts")) ($(mkRelFile "index.html") : fs) + ps <- blogIndexPageData myPosts + fs <- defaultPagePaths [1..size ps] + needIn (outputFolder $(mkRelDir "posts")) ($(mkRelFile "index.html") : fs) phony "by-tag-index" $ do - xs <- sortedPosts myPosts - forM_ (viewAllPostTags (snd <$> xs)) $ \t -> do - u <- parseRelDir $ T.unpack t - let xs' = filter (elem t . viewTags . snd) xs - ps <- paginate' postsPerPage xs' - fs <- defaultPagePaths [1..size ps] - let tagFolder = outputFolder $(mkRelDir "posts/tags") u - needIn tagFolder ($(mkRelFile "index.html") : fs) + ps <- blogTagIndexPageData myPosts + void $ flip HM.traverseWithKey ps $ \t z -> do + u <- parseRelDir $ T.unpack t + fs <- defaultPagePaths [1..size z] + let tagFolder = outputFolder $(mkRelDir "posts/tags") u + needIn tagFolder ($(mkRelFile "index.html") : fs) phony "by-month-index" $ do - xs <- sortedPosts myPosts - forM_ (viewAllPostTimes (snd <$> xs)) $ \t -> do - u <- parseRelDir $ defaultMonthUrlFormat t - let monthFolder = outputFolder $(mkRelDir "posts/months") u - let xs' = filter (sameMonth t . viewPostTime . snd) xs - ps <- paginate' postsPerPage xs' - fs <- defaultPagePaths [1..size ps] - needIn monthFolder ($(mkRelFile "index.html") : fs) + ps <- blogMonthIndexPageData myPosts + void $ flip HM.traverseWithKey ps $ \t z -> do + u <- parseRelDir $ defaultMonthUrlFormat t + fs <- defaultPagePaths [1..size z] + let monthFolder = outputFolder $(mkRelDir "posts/months") u + needIn monthFolder ($(mkRelFile "index.html") : fs) phony "docs" $ mapM withHtmlExtension tableOfContents >>= needIn outputFolder - - phony "posts" $ - getDirectoryFilesWithin' (["posts/*.md"] `within` sourceFolder) >>= - mapM (blinkAndMapM outputFolder withHtmlExtension) >>= - needWithin' + phony "posts" $ simplePipeline withHtmlExtension ["posts/*.md"] + phony "clean" $ do logInfo $ "Cleaning files in " <> display (PathDisplay outputFolder) removeFilesAfter outputFolder ["//*"] @@ -203,7 +224,7 @@ map ( \x -> goldenVsFile x x (replace "golden" "public" x) (return ())) xs - where replace from to' = intercalate to' . splitOn from + where replace fr to' = intercalate to' . splitOn fr main :: IO () main = do