shakebook 0.5.1.0 → 0.6.0.0
raw patch · 7 files changed
+129/−129 lines, 7 filesdep +ixsetdep −reludedep ~aesondep ~aeson-withdep ~pandoc
Dependencies added: ixset
Dependencies removed: relude
Dependency ranges changed: aeson, aeson-with, pandoc, path-extensions, shake-plus, slick
Files
- ChangeLog.md +5/−0
- shakebook.cabal +16/−16
- src/Shakebook/Conventions.hs +50/−39
- src/Shakebook/Data.hs +5/−19
- src/Shakebook/Defaults.hs +10/−10
- src/Shakebook/Feed.hs +4/−3
- test/Spec.hs +39/−42
ChangeLog.md view
@@ -1,5 +1,10 @@ # Changelog for Shakebook +## (v0.6.0.0)++* Drop `Display` instances for `Within` and `Path`.+* Introduce [ixset](https://hackage.haskell.org/package/ixset)+ ## (v0.5.1.0) * Add `tagIndex` and `monthIndex` instead of filter and partition functions.
shakebook.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f5bb0ca4ec7dfb075bca03025667a052ba4df3ca169c5d2746369855586f78fd+-- hash: 04043d969a1442f47c137e5bc16334c189a9fd62153a924984b247d4ed9470f2 name: shakebook-version: 0.5.1.0+version: 0.6.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@@ -37,24 +37,24 @@ 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 build-depends:- aeson- , aeson-with+ aeson >=1.5.2.0+ , aeson-with >=0.1.0.0 , base >=4.7 && <5 , comonad , comonad-extras , doctemplates , feed , free+ , ixset , lens , lens-aeson , mustache- , pandoc+ , pandoc >=2.9.2.1 , pandoc-types- , path-extensions- , relude+ , path-extensions >=0.0.1.0 , rio- , shake-plus- , slick+ , shake-plus >=0.1.7.0+ , slick >=1.0.1.1 , split , text-time , zipper-extra@@ -70,25 +70,25 @@ 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+ aeson >=1.5.2.0+ , aeson-with >=0.1.0.0 , base >=4.7 && <5 , comonad , comonad-extras , doctemplates , feed , free+ , ixset , lens , lens-aeson , mustache- , pandoc+ , pandoc >=2.9.2.1 , pandoc-types- , path-extensions- , relude+ , path-extensions >=0.0.1.0 , rio- , shake-plus+ , shake-plus >=0.1.7.0 , shakebook- , slick+ , slick >=1.0.1.1 , split , tasty , tasty-golden
src/Shakebook/Conventions.hs view
@@ -43,21 +43,22 @@ , genPageData , genTocNavbarData -, dateSortPosts-, monthIndex-, tagIndex+, Post(..)+, Tag(..)+, Posted(..)+, YearMonth(..) ) where import Control.Comonad.Cofree import Control.Comonad.Store import Control.Comonad.Zipper.Extra-import Control.Lens hiding ((:<))+import Control.Lens hiding ((:<), Indexable) import Data.Aeson as A import Data.Aeson.Lens import Data.Aeson.With+import Data.IxSet as Ix import Data.Text.Time import RIO hiding (view)-import qualified RIO.HashMap as HM import RIO.List import RIO.List.Partial import qualified RIO.Text as T@@ -97,11 +98,11 @@ withHighlighting = withStringField "highlighting-css" . T.pack . styleToCss -- | Add "next" field from input Value.-withNext :: Maybe Value -> (Value -> Value)-withNext = withValueMaybe "next"+withNext :: ToJSON a => a -> Value -> Value+withNext = withValue "next" -- | Add "pages" field from input [Value].-withPages :: [Value] -> (Value -> Value)+withPages :: ToJSON a => [a] -> Value -> Value withPages = withArrayField "pages" -- | Add "prettydate" field using input Text.@@ -109,15 +110,15 @@ withPrettyDate = withStringField "pretty-date" -- | Add "previous" field using input Value.-withPrevious :: Maybe Value -> (Value -> Value)-withPrevious = withValueMaybe "previous"+withPrevious :: ToJSON a => a -> Value -> Value+withPrevious = withValue "previous" -- | Add "posts" field based on input [Value].-withPosts :: [Value] -> Value -> Value+withPosts :: ToJSON a => [a] -> Value -> Value withPosts = withArrayField "posts" -- | Add "recent-posts" field using input Value.-withRecentPosts :: [Value] -> Value -> Value+withRecentPosts :: ToJSON a => [a] -> Value -> Value withRecentPosts = withArrayField "recent-posts" -- | Add "site-title" field from input Text.@@ -125,19 +126,19 @@ withSiteTitle = withStringField "site-title" -- | Add "social-links" field based on input [Value].-withSocialLinks :: [Value] -> Value -> Value+withSocialLinks :: ToJSON a => [a] -> Value -> Value withSocialLinks = withArrayField "social-links" -- | Add "subsections" field based on input [Value].-withSubsections :: [Value] -> (Value -> Value)+withSubsections :: ToJSON a => [a] -> Value -> Value withSubsections = withArrayField "subsections" -- | Add "tag-index" field based on input [Value].-withTagIndex :: [Value] -> Value -> Value+withTagIndex :: ToJSON a => [a] -> Value -> Value withTagIndex = withArrayField "tag-index" -- | Add "tag-links" field based on input [Value].-withTagLinks :: [Value] -> Value -> Value+withTagLinks :: ToJSON a => [a] -> Value -> Value withTagLinks = withArrayField "tag-links" -- | Add "teaser" field based on input Text.@@ -149,8 +150,8 @@ withTitle = withStringField "title" -- | 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+enrichPrettyDate :: (UTCTime -> Text) -> Value -> Value+enrichPrettyDate f v = withPrettyDate (f . viewPostTime $ v) v -- | Assuming a "tags" field, enrich using withTagLinks. enrichTagLinks :: (Text -> Text) -> Value -> Value@@ -181,34 +182,44 @@ genLinkData :: Text -> Text -> Value genLinkData x u = object ["id" A..= String x, "url" A..= String u] --- | Create a `HashMap` of posts indexed by tag.-tagIndex :: [Value] -> HashMap Text [Value]-tagIndex xs = HM.fromList [(t, filter (elem t . viewTags) xs) | t <- viewAllPostTags xs]+newtype Post = Post { unPost :: Value }+ deriving (Show, Eq, Ord, Data, Typeable, ToJSON) --- | Create a `HashMap` of posts indexed by year-month..-monthIndex :: [Value] -> HashMap Text [Value]-monthIndex xs = HM.fromList [(t, filter ((== t) . T.pack . formatTime defaultTimeLocale "%Y-%m" . viewPostTime) xs) | t <- nub (T.pack . formatTime defaultTimeLocale "%Y-%m" <$> viewAllPostTimes xs)]+newtype Tag = Tag Text+ deriving (Show, Eq, Ord, Data, Typeable) --- | Sort a lists of posts by date.-dateSortPosts :: [Value] -> [Value]-dateSortPosts = sortOn (Down . viewPostTime)+newtype Posted = Posted UTCTime+ deriving (Show, Eq, Ord, Data, Typeable) +newtype YearMonth = YearMonth (Integer, Int)+ deriving (Show, Eq, Ord, Data, Typeable)++newtype SrcFile = SrcFile Text+ deriving (Show, Eq, Ord, Data, Typeable)++instance Indexable Post where+ empty = ixSet [ (ixFun (fmap Tag . viewTags . unPost))+ , (ixFun (pure . Posted . viewPostTime . unPost))+ , (ixFun (pure . YearMonth . (\(a,b,_) -> (a,b)) . toGregorian . utctDay . viewPostTime . unPost))+ , (ixFun (pure . SrcFile . viewSrcPath . unPost))+ ]+ -- | 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+ -> 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+ -> IxSet Post+ -> Value genBlogNavbarData a b f g xs = object [ "toc1" A..= object [ "title" A..= String a , "url" A..= String b- , "toc2" A..= Array (V.fromList $ map toc2 (HM.elems $ monthIndex xs)) ]+ , "toc2" A..= Array (V.fromList $ map (uncurry toc2) $ groupDescBy 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) ]+ toc2 _ [] = object []+ toc2 (YearMonth (_, _)) t@(x : _) = object [ "title" A..= String (f (viewPostTime . unPost $ x))+ , "url" A..= String (g (viewPostTime . unPost $ x))+ , "toc3" A..= Array (V.fromList $ sortOn (Down . viewPostTime) $ (unPost <$> t)) ] -- | Create a toc navbar object for a docs section, with layers "toc1", "toc2" and "toc3". genTocNavbarData :: Cofree [] Value -> Value@@ -228,6 +239,6 @@ -> (Text -> Text) -> Int -> m (Zipper [] Value)-genIndexPageData xs g h n = do - zs <- paginate' n xs+genIndexPageData xs g h n = do+ zs <- paginate' n $ sortOn (Down . viewPostTime) xs return $ extend (genPageData g h) zs
src/Shakebook/Data.hs view
@@ -1,31 +1,17 @@ {-# LANGUAGE TemplateHaskell #-} module Shakebook.Data where -import Control.Comonad.Env as E-import Control.Lens hiding ((:<))-import Data.Aeson as A+import Control.Comonad.Env as E+import Control.Lens hiding ((:<))+import Data.Aeson as A import Data.Aeson.Lens import Data.Aeson.With import Development.Shake.Plus import Path.Extensions-import RIO hiding (Lens', lens, view)-import qualified RIO.Text as T+import RIO hiding (Lens', lens, view)+import qualified RIO.Text as T import Shakebook.Pandoc import Text.Pandoc--newtype PathDisplay a t = PathDisplay (Path a t)--instance Display (PathDisplay a t) where- display (PathDisplay f) = displayBytesUtf8 . fromString . toFilePath $ f--newtype WithinDisplay a t = WithinDisplay (Within a t)--instance Display (WithinDisplay a (Path b t)) where- display (WithinDisplay (WithinT (EnvT e (Identity a)))) = display (PathDisplay e) <> "[" <> display (PathDisplay a) <> "]"--instance Display [WithinDisplay a (Path b t)] where- display [] = ""- display (x : xs) = display x <> " : " <> display xs -- | View the "content" field of a JSON value. viewContent :: Value -> Text
src/Shakebook/Defaults.hs view
@@ -1,28 +1,28 @@ {-# LANGUAGE TemplateHaskell #-} module Shakebook.Defaults where -import Data.Aeson as A+import Data.Aeson as A import Development.Shake.Plus import RIO-import qualified RIO.Map as M-import qualified RIO.Text as T+import qualified RIO.Map as M+import qualified RIO.Text as T import RIO.Time import Shakebook.Conventions import Text.DocTemplates import Text.Pandoc.Definition import Text.Pandoc.Options -defaultMonthUrlFormat :: UTCTime -> String-defaultMonthUrlFormat = formatTime defaultTimeLocale "%Y-%m"+defaultMonthUrlFormat :: UTCTime -> Text+defaultMonthUrlFormat = T.pack . formatTime defaultTimeLocale "%Y-%m" -defaultPrettyMonthFormat :: UTCTime -> String-defaultPrettyMonthFormat = formatTime defaultTimeLocale "%B, %Y"+defaultPrettyMonthFormat :: UTCTime -> Text+defaultPrettyMonthFormat = T.pack . formatTime defaultTimeLocale "%B, %Y" -defaultPrettyTimeFormat :: UTCTime -> String-defaultPrettyTimeFormat = formatTime defaultTimeLocale "%A, %B %d, %Y"+defaultPrettyTimeFormat :: UTCTime -> Text+defaultPrettyTimeFormat = T.pack . formatTime defaultTimeLocale "%A, %B %d, %Y" defaultMonthUrlFragment :: UTCTime -> Text-defaultMonthUrlFragment t = T.pack $ "/posts/months/" <> defaultMonthUrlFormat t+defaultMonthUrlFragment t = "/posts/months/" <> defaultMonthUrlFormat t defaultEnrichPost :: Value -> Value defaultEnrichPost = enrichTeaser "<!--more-->"
src/Shakebook/Feed.hs view
@@ -6,11 +6,12 @@ import Data.Aeson import Development.Shake.Plus import RIO+import RIO.List import RIO.List.Partial-import qualified RIO.Text.Lazy as TL+import qualified RIO.Text.Lazy as TL import Shakebook.Conventions import Shakebook.Data-import Text.Atom.Feed as Atom+import Text.Atom.Feed as Atom import Text.Atom.Feed.Export -- | Convert a Post to an Atom Entry@@ -21,7 +22,7 @@ -- | 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 fs = asAtomEntry <$> sortOn (Down . viewPostTime) xs let t = Atom.nullFeed baseUrl (Atom.TextString title) $ Atom.entryUpdated (head fs) case textFeed (t { Atom.feedEntries = fs }) of Just a -> writeFile' out $ TL.toStrict a
test/Spec.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE TemplateHaskell #-} -import Control.Lens hiding ((:<))+import Control.Lens hiding ((:<)) import Data.Aeson.With+import qualified Data.IxSet as Ix import Data.List.Split-import Data.Text.Time import Path.Extensions import RIO-import RIO.Partial-import qualified RIO.HashMap as HM+import qualified RIO.HashMap as HM import RIO.List import RIO.List.Partial-import qualified RIO.Text as T+import RIO.Partial+import qualified RIO.Text as T+import RIO.Time import Shakebook import Test.Tasty import Test.Tasty.Golden@@ -54,47 +55,43 @@ readMDC <- newCache $ loadMarkdownAsJSON defaultMarkdownReaderOptions defaultHtml5WriterOptions - postsC <- newCache $ \w -> do- xs <- batchLoadWithin' w readMDC- return $ defaultEnrichPost <$> xs-- sortedPosts <- newCache $ \fp -> do- allPosts <- postsC fp- return $ sortOn (Down . viewPostTime . snd) $ HM.toList allPosts-- getRecentPosts <- newCache $ \fp -> do- xs <- sortedPosts fp- return $ take numRecentPosts (snd <$> xs)+ postsIx <- newCache $ \fp -> do+ xs <- batchLoadWithin' fp readMDC+ return $ Ix.fromList $ Post <$> HM.elems (defaultEnrichPost <$> xs) getBlogNavbar <- newCache $ \fp -> do- allPosts <- postsC fp- return $ genBlogNavbarData "Blog" "/posts/"- (T.pack . defaultPrettyMonthFormat)- defaultMonthUrlFragment (HM.elems allPosts)+ xs <- postsIx fp+ return $ genBlogNavbarData "Blog" "/posts/" defaultPrettyMonthFormat defaultMonthUrlFragment xs postsZ <- newCache $ \fp -> do- xs <- sortedPosts fp- zs <- ifor xs $ \i (k, _) -> do- z <- zipper' (snd <$> xs)- return (k, seek i z)+ xs <- postsIx fp+ let ys = Ix.toDescList (Ix.Proxy :: Ix.Proxy Posted) xs+ zs <- ifor ys $ \i v -> do+ z <- zipper' (unPost <$> ys)+ return (viewSrcPath (unPost v), seek i z) return $ HM.fromList zs blogIndexPageData <- newCache $ \fp -> do- xs <- sortedPosts fp- genIndexPageData (snd <$> xs) "Posts" ("/posts/pages/" <>) postsPerPage+ xs <- postsIx fp+ genIndexPageData (unPost <$> Ix.toList xs) "Posts" ("/posts/pages/" <>) postsPerPage blogTagIndexPageData <- newCache $ \fp -> do- xs <- sortedPosts fp- flip HM.traverseWithKey (tagIndex (snd <$> xs)) $ \t ys ->- genIndexPageData ys ("Posts tagged " <> t) (("/posts/tags/" <> t <> "/pages/") <>) postsPerPage+ xs <- postsIx fp+ k <- forM (Ix.groupDescBy xs) $ \((Tag t), ys) -> do+ z <- genIndexPageData (unPost <$> ys) ("Posts tagged " <> t) (("/posts/tags/" <> t <> "/pages/") <>) postsPerPage+ return (t, z)+ return $ HM.fromList k blogMonthIndexPageData <- newCache $ \fp -> do- xs <- sortedPosts fp- flip HM.traverseWithKey (monthIndex (snd <$> xs)) $ \t ys ->- let t' = parseISODateTime t- in genIndexPageData ys- (("Posts from " <>) . T.pack . defaultPrettyMonthFormat $ t')- (("/posts/months/" <> T.pack (defaultMonthUrlFormat t') <> "/pages/") <>) postsPerPage+ xs <- postsIx fp+ k <- forM (Ix.groupDescBy xs) $ \(YearMonth (y,m), ys) -> do+ let t' = UTCTime (fromGregorian y m 1) 0+ z <- genIndexPageData (unPost <$> ys)+ (("Posts from " <>) . defaultPrettyMonthFormat $ t')+ (("/posts/months/" <> defaultMonthUrlFormat t' <> "/pages/") <>)+ postsPerPage+ return (defaultMonthUrlFormat t', z)+ return $ HM.fromList k let myPosts = ["posts/*.md"] `within` sourceFolder @@ -102,11 +99,11 @@ s' = (`within` sourceFolder) myBuildPage tmpl v out = do- rs <- getRecentPosts myPosts+ rs <- postsIx myPosts let v' = withHighlighting pygments . withSocialLinks mySocial . withSiteTitle siteTitle- . withRecentPosts rs $ v+ . withRecentPosts (take numRecentPosts $ Ix.toDescList (Ix.Proxy :: Ix.Proxy Posted) rs) $ v buildPageActionWithin (s' tmpl) v' out myBuildBlogPage tmpl v out = do@@ -125,13 +122,13 @@ 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)+ case HM.lookup (T.pack . toFilePath . extract $ src) xs of+ Nothing -> logError $ "Attempting to lookup non-existent post " <> displayShow src Just x -> myBuildBlogPage $(mkRelFile "templates/post.html") (extract x) out toc' <- mapM (mapM withHtmlExtension) $ fmap o' tableOfContents void . sequence . flip extend toc' $ \xs -> (toFilePath <$> extract xs) %^> \out -> do- let getDoc = readMDC <=< blinkAndMapM sourceFolder withMdExtension + let getDoc = readMDC <=< blinkAndMapM sourceFolder withMdExtension ys <- mapM getDoc toc' zs <- mapM getDoc (fmap extract . unwrap $ xs) v <- getDoc out@@ -145,7 +142,7 @@ let n = (+ (-1)) . read . (!! 2) . splitOn "/" . toFilePath . extract $ out xs <- blogIndexPageData myPosts myBuildPostListPage (seek n xs) out- + o' "posts/tags/*/index.html" %^> \out -> do let t = (!! 2) . splitOn "/" . toFilePath . extract $ out i <- parseRelFile $ "posts/tags/" <> t <> "/pages/1/index.html"@@ -209,7 +206,7 @@ phony "posts" $ simplePipeline withHtmlExtension ["posts/*.md"] phony "clean" $ do- logInfo $ "Cleaning files in " <> display (PathDisplay outputFolder)+ logInfo $ "Cleaning files in " <> displayShow outputFolder removeFilesAfter outputFolder ["//*"] tests :: [FilePath] -> TestTree