shakebook 0.11.0.0 → 0.13.1.0
raw patch · 18 files changed
+515/−769 lines, 18 filesdep +compdocdep +composite-aeson-cofree-listdep +composite-aeson-pathdep −binarydep −http-conduitdep −mustachedep ~aesondep ~binary-instancesdep ~composite-aeson
Dependencies added: compdoc, composite-aeson-cofree-list, composite-aeson-path, composite-aeson-throw, composite-aeson-writeonly, composite-binary, composite-hashable, composite-tuple, composite-xstep, pandoc-throw, path-utils, skylighting, stache
Dependencies removed: binary, http-conduit, mustache, slick, text-time
Dependency ranges changed: aeson, binary-instances, composite-aeson, composite-base, lucid-cdn, shake-plus-extended
Files
- ChangeLog.md +19/−0
- README.md +8/−3
- shakebook.cabal +46/−31
- src/Shakebook.hs +26/−7
- src/Shakebook/Aeson.hs +16/−39
- src/Shakebook/Composite.hs +0/−34
- src/Shakebook/Conduit.hs +0/−38
- src/Shakebook/Conventions.hs +170/−353
- src/Shakebook/Defaults.hs +11/−11
- src/Shakebook/Feed.hs +0/−2
- src/Shakebook/IxSet.hs +14/−0
- src/Shakebook/Lucid.hs +49/−0
- src/Shakebook/Mustache.hs +12/−30
- src/Shakebook/Pandoc.hs +3/−79
- src/Shakebook/Sitemap.hs +0/−2
- src/Shakebook/Tuple.hs +5/−0
- src/Shakebook/Utils.hs +0/−14
- test/Spec.hs +136/−126
ChangeLog.md view
@@ -1,5 +1,24 @@ # Changelog for Shakebook +## (v0.13.0.0)++* Completely unrecognizable rework.+* Shakebook will now function as a prelude for site building.+* Recommended style changed to forward mode.+* Changed mustache library to stache.+* Now exports IxSet as a separate module.++## (v0.12.0.0)++* Standardize top level strategy for supplying template values as follows:+ * Pick an oracle that returns a composite.+ * Pick a template.+ * Pick a formatting strategy.++## (v0.11.0.0)++* Introduce [composite-aeson](https://hackage.haskell.org/package/composite-aeson) for supplying and formatting template values.+ ## (v0.10.0.0) * Add [lucid](https://hackage.haskell.org/package/lucid).
README.md view
@@ -1,8 +1,13 @@-# Shakebook - Static Site & Technical Documentation Generator+# Shakebook - Static Site & Technical Documentation Prelude -Shakebook is a collection of data handlers, shake rules and useful conventions-for generating technical documentation and blogs. This is the API library.+Shakebook is a replacement prelude specifically for static site and technical documentation generation. To get started you can use the template repository at http://gitlab.com/shakebook-template/shakebook-template For full documentation see http://shakebook.site.++Note: Shakebook is not actively maintained. You may stil find this useful as a+reference, but if you want to make a static site with+[shake-plus](https://hackage.haskell.org/package/shake-plus) then you might+prefer to use the+[slick-plus-template](https://gitlab.com/slick-template-plus/slick-template-plus.gitlab.io).
shakebook.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: shakebook-version: 0.11.0.0+version: 0.13.1.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@@ -23,57 +23,64 @@ exposed-modules: Shakebook Shakebook.Aeson- Shakebook.Composite- Shakebook.Conduit Shakebook.Conventions Shakebook.Defaults Shakebook.Feed+ Shakebook.IxSet+ Shakebook.Lucid Shakebook.Mustache Shakebook.Pandoc Shakebook.Sitemap+ Shakebook.Tuple Shakebook.Url- Shakebook.Utils other-modules: Paths_shakebook hs-source-dirs: src- default-extensions: BangPatterns BinaryLiterals BlockArguments 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 TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -fno-warn-orphans -Wredundant-constraints+ default-extensions: BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingVia DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -fno-warn-orphans -fprint-potential-instances -Wredundant-constraints build-depends:- aeson+ aeson >=1.4.7.0 && <1.6 , aeson-better-errors , aeson-with >=0.1.1.0 , base >=4.7 && <5- , binary- , binary-instances+ , binary-instances >=1.0.0.1 && <1.1 , comonad , comonad-extras- , composite-aeson >=0.7.3.0- , composite-base >=0.7.3.0+ , compdoc+ , composite-aeson >=0.7.4.0 && <0.8+ , composite-aeson-cofree-list+ , composite-aeson-path >=0.7.4.0 && <0.8+ , composite-aeson-throw+ , composite-aeson-writeonly+ , composite-base >=0.7.4.0 && <0.8+ , composite-binary >=0.7.4.0 && <0.8+ , composite-hashable >=0.7.4.0 && <0.8+ , composite-tuple+ , composite-xstep , doctemplates , feed , free , hashable-time- , http-conduit , ixset-typed >=0.5 , ixset-typed-conversions , lens , lens-aeson , lucid- , lucid-cdn >=0.1.1.0+ , lucid-cdn >=0.2.0.0 && <0.3 , mtl- , mustache , pandoc+ , pandoc-throw , pandoc-types , path , path-extensions >=0.1.0.1+ , path-utils , rio , shake-plus >=0.3.0.0- , shake-plus-extended >=0.2.0.0+ , shake-plus-extended >=0.4.1.0 , sitemap-gen- , slick >=1.0.1.1- , split- , text-time+ , skylighting+ , stache , vinyl , zipper-extra >=0.1.3.0 default-language: Haskell2010@@ -85,46 +92,54 @@ Paths_shakebook hs-source-dirs: test- default-extensions: BangPatterns BinaryLiterals BlockArguments 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 TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -fno-warn-orphans -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ default-extensions: BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingVia DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -fno-warn-orphans -fprint-potential-instances -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends:- aeson+ aeson >=1.4.7.0 && <1.6 , aeson-better-errors , aeson-with >=0.1.1.0 , base >=4.7 && <5- , binary- , binary-instances+ , binary-instances >=1.0.0.1 && <1.1 , comonad , comonad-extras- , composite-aeson >=0.7.3.0- , composite-base >=0.7.3.0+ , compdoc+ , composite-aeson >=0.7.4.0 && <0.8+ , composite-aeson-cofree-list+ , composite-aeson-path >=0.7.4.0 && <0.8+ , composite-aeson-throw+ , composite-aeson-writeonly+ , composite-base >=0.7.4.0 && <0.8+ , composite-binary >=0.7.4.0 && <0.8+ , composite-hashable >=0.7.4.0 && <0.8+ , composite-tuple+ , composite-xstep , doctemplates , feed , free , hashable-time- , http-conduit , ixset-typed >=0.5 , ixset-typed-conversions , lens , lens-aeson , lucid- , lucid-cdn >=0.1.1.0+ , lucid-cdn >=0.2.0.0 && <0.3 , mtl- , mustache , pandoc+ , pandoc-throw , pandoc-types , path , path-extensions >=0.1.0.1+ , path-utils , rio , shake-plus >=0.3.0.0- , shake-plus-extended >=0.2.0.0+ , shake-plus-extended >=0.4.1.0 , shakebook , sitemap-gen- , slick >=1.0.1.1+ , skylighting , split+ , stache , tasty , tasty-golden- , text-time , vinyl , zipper-extra >=0.1.3.0 default-language: Haskell2010
src/Shakebook.hs view
@@ -1,7 +1,5 @@ {- | Module : Shakebook- Copyright : Copyright (C) 2020 Daniel Firth- Maintainer : Daniel Firth <dan.firth@homotopic.tech License : MIT Stability : experimental @@ -9,38 +7,59 @@ as well as shake-plus, aeson and comonad utilities. -} module Shakebook (- module Control.Comonad.Cofree+ module Composite.Aeson+, module Composite.Record+, module Composite.Record.Tuple+, module Control.Comonad.Cofree , module Control.Comonad.Store , module Control.Comonad.Store.Zipper , module Control.Comonad.Zipper.Extra , module Data.Aeson+, module Data.Vinyl+, module Data.Vinyl.TypeLevel , module Development.Shake.Plus+, module Development.Shake.Plus.Extended+, module Development.Shake.Plus.Extended.Simple+, module Development.Shake.Plus.Forward+, module Path.Utils , module Shakebook.Aeson-, module Shakebook.Conduit , module Shakebook.Conventions , module Shakebook.Defaults , module Shakebook.Feed+, module Shakebook.Lucid , module Shakebook.Mustache , module Shakebook.Pandoc , module Shakebook.Sitemap , module Shakebook.Url , module Text.Pandoc.Highlighting+, module Text.Compdoc ) where +import Composite.Aeson+import Composite.Record+import Composite.Record.Binary ()+import Composite.Record.Hashable ()+import Composite.Record.Tuple (pattern (:|:)) 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 Data.Vinyl hiding (RElem, rlens, rlens')+import Data.Vinyl.TypeLevel hiding (RDelete)+import Development.Shake.Plus hiding ((:->))+import Development.Shake.Plus.Extended+import Development.Shake.Plus.Extended.Simple+import Development.Shake.Plus.Forward+import Path.Utils import Shakebook.Aeson-import Shakebook.Composite()-import Shakebook.Conduit import Shakebook.Conventions import Shakebook.Defaults import Shakebook.Feed hiding (Link)+import Shakebook.Lucid import Shakebook.Mustache import Shakebook.Pandoc import Shakebook.Sitemap import Shakebook.Url+import Text.Compdoc import Text.Pandoc.Highlighting
src/Shakebook/Aeson.hs view
@@ -1,44 +1,21 @@-module Shakebook.Aeson where+module Shakebook.Aeson (+ htmlJsonFormat+, styleJsonFormat+, cofreeListJsonFormat+, writeOnlyJsonFormat+, noRead+, WriteOnlyJsonField+) where import Composite.Aeson-import Control.Monad.Except-import Data.Aeson-import Data.Aeson.BetterErrors-import Lucid-import Path+import Composite.Aeson.Format.CofreeList+import Composite.Aeson.WriteOnly+import Data.Aeson import RIO-import qualified RIO.Text as T-import qualified RIO.Text.Lazy as LT-import Text.Pandoc.Highlighting--newtype AesonParseException a = AesonParseException a- deriving (Eq, Show, Ord)---instance (Typeable a, Show a) => Exception (AesonParseException a)--parseValue' :: MonadThrow m => JsonFormat Void x -> Value -> m x-parseValue' f v = do- let a = parseValue (fromJsonWithFormat f) v- either (throwM . AesonParseException) return a--data WriteOnlyJsonField = WriteOnlyJsonField- deriving Show--lucidJsonFormat :: JsonFormat e (Html ())-lucidJsonFormat = jsonFormatWithoutCustomError $ JsonFormat $ JsonProfunctor (String . LT.toStrict . renderText) (throwCustomError WriteOnlyJsonField)--styleJsonFormat :: JsonFormat e Style-styleJsonFormat = jsonFormatWithoutCustomError $ JsonFormat $ JsonProfunctor (String . T.pack . styleToCss) (throwCustomError WriteOnlyJsonField)--relFileJsonFormat :: JsonFormat e (Path Rel File)-relFileJsonFormat = aesonJsonFormat--relDirJsonFormat :: JsonFormat e (Path Rel Dir)-relDirJsonFormat = aesonJsonFormat+import Shakebook.Lucid -absFileJsonFormat :: JsonFormat e (Path Abs File)-absFileJsonFormat = aesonJsonFormat+htmlJsonFormat :: JsonFormat e HtmlFragment+htmlJsonFormat = writeOnlyJsonFormat $ String . unHtmlFragment -absDirJsonFormat :: JsonFormat e (Path Abs Dir)-absDirJsonFormat = aesonJsonFormat+styleJsonFormat :: JsonFormat e StyleFragment+styleJsonFormat = writeOnlyJsonFormat $ String . unStyleFragment
− src/Shakebook/Composite.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-module Shakebook.Composite where--import Composite.Record-import Development.Shake.Plus hiding ((:->))-import RIO--instance Hashable a => Hashable (s :-> a) where- hashWithSalt n x = hashWithSalt n $ getVal x--instance Binary a => Binary (s :-> a) where- put = put . getVal- get = fmap (runIdentity . val) get--instance NFData (s :-> a) where- rnf x = seq x ()--instance Binary (Record '[])--instance (Binary a, Binary (Record xs), x ~ (s :-> a)) => Binary (Record (x : xs)) where- put (x :*: xs) = put x >> put xs- get = liftA2 (:*:) get get--instance NFData (Record '[]) where- rnf RNil = ()--instance (NFData a, NFData (Record xs), x ~ (s :-> a)) => NFData (Record (x : xs)) where- rnf (x :*: xs) = rnf x `seq` rnf xs--instance Hashable (Record '[]) where- hashWithSalt n RNil = n `hashWithSalt` ()--instance (Hashable a, Hashable (Record xs), x ~ (s :-> a)) => Hashable (Record (x : xs)) where- hashWithSalt n (x :*: xs) = n `hashWithSalt` x `hashWithSalt` xs
− src/Shakebook/Conduit.hs
@@ -1,38 +0,0 @@-{- |- Module : Shakebook.Conduit- Copyright : Copyright (C) 2020 Daniel Firth- Maintainer : Daniel Firth <dan.firth@homotopic.tech- License : MIT- Stability : experimental--Utilities for using conduit to store remote caches.--}--module Shakebook.Conduit (- RemoteJSONLookup(..)-, addRemoteJSONOracleCache-) where--import Data.Aeson-import Data.Binary.Instances.Aeson ()-import Development.Shake.Plus-import Network.HTTP.Simple-import RIO-import qualified RIO.Text as T---- | Remote json lookup for an oracle, this should contain a URL as Text.-newtype RemoteJSONLookup = RemoteJSONLookup Text- deriving (Show, Typeable, Eq)--type instance RuleResult RemoteJSONLookup = Value--deriving instance Hashable RemoteJSONLookup-deriving instance Binary RemoteJSONLookup-deriving instance NFData RemoteJSONLookup---- | Adds an oracle cache for looking up json from a remote server.-addRemoteJSONOracleCache :: (MonadReader r m, MonadRules m) => m (RemoteJSONLookup -> RAction r Value)-addRemoteJSONOracleCache = addOracleCache $ \(RemoteJSONLookup x) -> do- initReq <- parseRequest $ T.unpack x- (y :: Response Value) <- httpJSON initReq- return $ getResponseBody y
src/Shakebook/Conventions.hs view
@@ -1,146 +1,38 @@+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {- | Module : Shakebook.Conventions- Copyright : Copyright (C) 2020 Daniel Firth- Maintainer : Daniel Firth <dan.firth@homotopic.tech License : MIT Stability : experimental Conventions used in Shakebook projects, common lenses, generators, and indexing wrappers over Values. -}-module Shakebook.Conventions (- -- * Fields- FCdnImports-, FContent-, FDescription-, FHighlighting-, FItems-, FPageLinks-, FPosted-, FImage-, FModified-, FNext-, FRecentPosts-, FPrettyDate-, FPrevious-, FSiteTitle-, FSocial-, FSrcPath-, FSubsections-, FTags-, FTagLinks-, FTeaser-, FTitle-, FToc-, FUrl-, FPageNo---, fCdnImports-, fContent-, fDescription-, fHighlighting-, fItems-, fPageLinks-, fPosted-, fImage-, fModified-, fNext-, fRecentPosts-, fPrettyDate-, fPrevious-, fSiteTitle-, fSocial-, fSrcPath-, fSubsections-, fTags-, fTagLinks-, fTeaser-, fTitle-, fToc-, fUrl-, fPageNo-, fId-- -- * Generations-, genBlogNav-, genDocNav-, addDerivedUrl-, asSitemapUrl-, asAtomEntry-, addTagLinks-, addPrettyDate-, addTeaser-- -- * Indexing-, Link-, Tag(..)-, Posted(..)-, YearMonth(..)-, fromYearMonthPair-, toYearMonthPair-- -- * Stages-, RawPost-, Stage1Post-, RawDoc-, Stage1Doc-- -- * Oracles-, BlogNav(..)-, DocNav(..)-, IndexRoot(..)-, IndexPages(..)-, RecentPosts(..)-, PostsFilter(..)-, indexFilter-, defaultIndexRoots-, defaultIndexPages-- -- * Formatting-, basicMDJsonFormatRecord-, basicMDJsonFormat-, rawDocJsonFormat-, rawPostJsonFormat-, rawSingleJsonFormat-, stage1PostJsonFormat-, stage1DocJsonFormat-, finalPostJsonFormat-, mainPageJsonFormat-, indexPageJsonFormatRecord-, postIndexPageJsonFormat-, finalDocJsonFormat-- -- * Templates-, TMain-, TDoc-, TPost-, TPostIndex-, Enriched-) where+module Shakebook.Conventions where import Composite.Aeson+import Composite.Aeson.Path import Composite.Record+import qualified Composite.Record.Tuple as C import Composite.TH import Control.Comonad.Cofree import Control.Comonad.Store+import Control.Comonad.Store.Zipper import Data.Binary.Instances.Time () import Data.Hashable.Time import Data.IxSet.Typed as Ix+import Data.Vinyl hiding (RElem)+import Data.Vinyl.TypeLevel import Development.Shake.Plus hiding ((:->)) import Lucid import RIO-import RIO.List-import RIO.List.Partial import qualified RIO.Text as T-import qualified RIO.Text.Partial as T import RIO.Time import Shakebook.Aeson-import Shakebook.Defaults import qualified Shakebook.Feed as Atom+import Shakebook.Lucid import Shakebook.Sitemap-import Text.Pandoc.Highlighting+import Text.Compdoc import Control.Comonad.Zipper.Extra withLensesAndProxies [d|@@ -150,307 +42,232 @@ type Link = '[FId, FUrl] +linkJsonFormat :: JsonFormat e (Record Link)+linkJsonFormat = recordJsonFormat $ field textJsonFormat :& field textJsonFormat :& RNil+ withLensesAndProxies [d|- type FCdnImports = "cdn-imports" :-> Text- type FContent = "content" :-> Text+ type FCdnImports = "cdn-imports" :-> HtmlFragment type FDescription = "description" :-> Text- type FHighlighting = "highlighting" :-> Style+ type FHighlighting = "highlighting" :-> StyleFragment type FImage = "image" :-> Maybe Text-+ type FItems x = "items" :-> [Record x] type FModified = "modified" :-> UTCTime- type FNext = "next" :-> Text+ type FNext = "next" :-> HtmlFragment+ type FPageLinks = "page-links" :-> HtmlFragment type FPageNo = "pageno" :-> Int- type FPageLinks = "page-links" :-> [Record Link] type FPrettyDate = "pretty-date" :-> UTCTime- type FPrevious = "previous" :-> Text+ type FPrevious = "previous" :-> HtmlFragment type FPosted = "posted" :-> UTCTime- type FItems x = "items" :-> [Record x] type FRecentPosts x = "recent-posts" :-> [Record x] type FSiteTitle = "site-title" :-> Text type FSrcPath = "src-path" :-> Path Rel File- type FSocial = "social" :-> [Record Link]+ type FSocialLinks = "social" :-> [Record Link] type FSubsections x = "subsections" :-> [Record x] type FTags = "tags" :-> [Text] type FTagLinks = "tag-links" :-> [Record Link] type FTeaser = "teaser" :-> Text type FTitle = "title" :-> Text- type FToc = "toc" :-> Text-+ type FTocHtml = "toc" :-> HtmlFragment+ type FTocCF = "toc" :-> Cofree [] (Record Link) |] --- | Tag indices for a `Post` for use with `IxSet`.-newtype Tag = Tag Text- deriving (Show, Eq, Ord, Data, Typeable, Hashable, Binary, NFData, Generic)---- | Posted index for a `Post` for use with `IxSet`.-newtype Posted = Posted UTCTime- deriving (Show, Eq, Ord, Data, Typeable, Hashable, Generic, NFData)---- | YearMonth (yyyy, mm) index for a `Post` for use with `IxSet`.-newtype YearMonth = YearMonth (Integer, Int)- deriving (Show, Eq, Ord, Data, Typeable, Hashable, Binary, NFData, Generic)--toYearMonthPair :: UTCTime -> (Integer, Int)-toYearMonthPair = (\(a, b, _) -> (a, b)) . toGregorian . utctDay--fromYearMonthPair :: (Integer, Int) -> UTCTime-fromYearMonthPair (y,m) = UTCTime (fromGregorian y m 1) 0---- | Create a blog navbar object for a posts section, with layers "toc1", "toc2", and "toc3".-genBlogNav :: (IsIndexOf YearMonth ixs, RElem FPosted xs, RElem FUrl xs, RElem FTitle xs, MonadAction m)- => Text -- ^ "Top level title, e.g "Blog"- -> (UTCTime -> Text) -- ^ Formatting function to a UTCTime to a title.- -> IxSet ixs (Record xs)- -> HtmlT m ()-genBlogNav a f xs = do- ul_ $- li_ $ do- b <- lift $ askOracle $ IndexRoot AllPosts- a_ [href_ b] (toHtml a)- ul_ $ forM_ (groupDescBy xs) $ \(YearMonth(y, m), xs') -> do- k <- lift $ askOracle $ IndexRoot $ ByYearMonth $ YearMonth (y, m)- li_ $ a_ [href_ k] (toHtml . f $ fromYearMonthPair (y, m))- ul_ $ forM (sortOn (Down . view fPosted) xs') $ \x ->- li_ $ a_ [href_ $ view fUrl x] (toHtml $ view fTitle x)---- | Create a toc navbar object for a docs section, with layers "toc1", "toc2" and "toc3".-genDocNav :: (RElem FUrl xs, RElem FTitle xs) => Cofree [] (Record xs) -> Html ()-genDocNav (x :< xs) = ul_ $ li_ $ do- a_ [href_ $ view fUrl x] (toHtml $ view fTitle x)- forM_ xs genDocNav--asSitemapUrl :: (RElem FUrl xs, RElem FPosted xs) => Text -> Record xs -> SitemapUrl-asSitemapUrl baseUrl x = SitemapUrl {- sitemapLocation = baseUrl <> view fUrl x- , sitemapLastModified = Just (view fPosted x)- , sitemapChangeFrequency = Nothing- , sitemapPriority = Nothing-}---- | Convert a Post to an Atom Entry-asAtomEntry :: (RElem FContent xs, RElem FPosted xs, RElem FUrl xs, RElem FTitle xs) => Record xs -> Atom.Entry-asAtomEntry x = (Atom.nullEntry (view fUrl x)- (Atom.TextString $ view fTitle x)- (T.pack $ formatTime defaultTimeLocale (iso8601DateFormat Nothing) $ view fPosted x)) {- Atom.entryContent = Just $ Atom.TextContent (view fContent x)- }--addDerivedUrl :: (MonadThrow m, RElem FSrcPath xs) => (Path Rel File -> m Text) -> Record xs -> m (Record (FUrl : xs))-addDerivedUrl f xs = f (view fSrcPath xs) >>= \x -> return $ x :*: xs----- Stage 0 Types---- "Basic Markdown" - These two fields are always populated by the markdown loader - the source path and the main body content.-type BasicMD = FSrcPath : FContent : '[]--basicMDJsonFormatRecord :: JsonFormatRecord e BasicMD-basicMDJsonFormatRecord = field relFileJsonFormat- :& field textJsonFormat- :& RNil--basicMDJsonFormat :: JsonFormat e (Record BasicMD)-basicMDJsonFormat = recordJsonFormat basicMDJsonFormatRecord---- A 'RawDoc' contains three mandatory fields - title, description and modified.-type RawDoc = FDescription : FTitle : FModified : BasicMD--rawDocJsonFormatRecord :: JsonFormatRecord e RawDoc-rawDocJsonFormatRecord = field aesonJsonFormat- :& field defaultJsonFormat- :& field iso8601DateTimeJsonFormat- :& basicMDJsonFormatRecord--rawDocJsonFormat :: JsonFormat e (Record RawDoc)-rawDocJsonFormat = recordJsonFormat rawDocJsonFormatRecord---- A `RawPost` contains three mandatory fields, title, tags, and posted, and an optional image field.-type RawPost = FTitle : FImage : FTags : FPosted : BasicMD--rawPostJsonFormatRecord :: JsonFormatRecord e RawPost-rawPostJsonFormatRecord = field textJsonFormat- :& optionalField textJsonFormat- :& field (listJsonFormat textJsonFormat)- :& field (dateTimeJsonFormat defaultTimeLocale (regularDateTimeFormat "%F" "yyyy-mm-dd" :| []))- :& basicMDJsonFormatRecord--rawPostJsonFormat :: JsonFormat e (Record RawPost)-rawPostJsonFormat = recordJsonFormat rawPostJsonFormatRecord---- A `RawSingle` is a post without any tags or date information.-type RawSingle = FTitle : FImage : BasicMD--rawSingleJsonFormatRecord :: JsonFormatRecord e RawSingle-rawSingleJsonFormatRecord = field textJsonFormat- :& optionalField textJsonFormat- :& basicMDJsonFormatRecord+sbDisplayDateTimeJsonFormat :: JsonFormat e UTCTime+sbDisplayDateTimeJsonFormat = dateTimeJsonFormat defaultTimeLocale (regularDateTimeFormat "%A, %B %d, %Y" "yyyy-mm-dd" :| []) -rawSingleJsonFormat :: JsonFormat e (Record RawSingle)-rawSingleJsonFormat = recordJsonFormat rawSingleJsonFormatRecord+sbShortDateJsonFormat :: JsonFormat e UTCTime+sbShortDateJsonFormat = dateTimeJsonFormat defaultTimeLocale (regularDateTimeFormat "%F" "yyyy-mm-dd" :| []) ---- Stage 1 Types+type RawDocMeta = FModified : FTitle : FDescription : '[] --- Simple link object, used in a list for tags and social links.+type RawPostMeta = FPosted : FImage : FTitle : FTags : '[] -linkJsonFormatRecord :: JsonFormatRecord e Link-linkJsonFormatRecord = field textJsonFormat :& field textJsonFormat :& RNil+type RawSingleMeta = FImage : FTitle : '[] -linkJsonFormat :: JsonFormat e (Record Link)-linkJsonFormat = recordJsonFormat linkJsonFormatRecord+type RawDoc = Compdoc RawDocMeta -type URLised x = FUrl : x+type RawPost = Compdoc RawPostMeta -urlisedXJsonFormatRecord :: JsonFormatRecord e x -> JsonFormatRecord e (URLised x)-urlisedXJsonFormatRecord x = field textJsonFormat :& x+type RawSingle = Compdoc RawSingleMeta -type Stage1Post = FPrettyDate : FTagLinks : FTeaser : URLised RawPost+type Stage1PostExtras = FPrettyDate : FTagLinks : FTeaser : '[] -stage1PostJsonFormatRecord :: JsonFormatRecord e Stage1Post-stage1PostJsonFormatRecord = field (dateTimeJsonFormat defaultTimeLocale (regularDateTimeFormat "%A, %B %d, %Y" "yyyy-mm-dd" :| []))- :& field (listJsonFormat linkJsonFormat)- :& field textJsonFormat- :& urlisedXJsonFormatRecord rawPostJsonFormatRecord+type Stage1Post = Stage1PostExtras ++ RawPost -stage1PostJsonFormat :: JsonFormat e (Record Stage1Post)-stage1PostJsonFormat = recordJsonFormat stage1PostJsonFormatRecord+type IndexPage x = FPageLinks : FTocCF : FTitle : FItems x : FPageNo : '[] -type Stage1Doc = URLised RawDoc+type PostIndexPage = Routed (IndexPage (Routed Stage1Post)) -stage1DocJsonFormatRecord :: JsonFormatRecord e Stage1Doc-stage1DocJsonFormatRecord = urlisedXJsonFormatRecord rawDocJsonFormatRecord+type FinalDoc = FTocCF : FSubsections (Routed RawDoc) : Routed RawDoc -stage1DocJsonFormat :: JsonFormat e (Record Stage1Doc)-stage1DocJsonFormat = recordJsonFormat stage1DocJsonFormatRecord+type FinalPost = FTocCF : Routed Stage1Post ---- Stage 2 Types+type MainPage = FRecentPosts (Routed Stage1Post) : RawSingle --- Enrichment provides fields most pages display or can otherwise be safely ignored such as highlighting, json imports and social links.-type Enriched x = FSocial : FCdnImports : FHighlighting : FSiteTitle : x+type Routed x = FUrl : x -enrichedXJsonFormatRecord :: JsonFormatRecord e x -> JsonFormatRecord e (Enriched x)-enrichedXJsonFormatRecord x = field (listJsonFormat linkJsonFormat)- :& field textJsonFormat- :& field styleJsonFormat- :& field defaultJsonFormat- :& x+type Enrichment = FSocialLinks : FCdnImports : FHighlighting : FSiteTitle : '[] -type FinalDoc = FToc : FSubsections Stage1Doc : Enriched Stage1Doc+-- | Tag indices for a `Post` for use with `IxSet`.+newtype Tag = Tag { unTag :: Text }+ deriving stock (Show, Eq, Ord, Data, Typeable, Generic)+ deriving newtype (Hashable, Binary, NFData) -finalDocJsonFormatRecord :: JsonFormatRecord e FinalDoc-finalDocJsonFormatRecord = field textJsonFormat- :& field (listJsonFormat stage1DocJsonFormat)- :& enrichedXJsonFormatRecord stage1DocJsonFormatRecord+-- | Posted index for a `Post` for use with `IxSet`.+newtype Posted = Posted { unPosted :: UTCTime }+ deriving stock (Show, Eq, Ord, Data, Typeable, Generic)+ deriving newtype (Hashable, Binary, NFData) -finalDocJsonFormat :: JsonFormat e (Record FinalDoc)-finalDocJsonFormat = recordJsonFormat finalDocJsonFormatRecord+-- | YearMonth (yyyy, mm) index for a `Post` for use with `IxSet`.+newtype YearMonth = YearMonth { unYearMonth :: (Integer, Int) }+ deriving stock (Show, Eq, Ord, Data, Typeable, Generic)+ deriving newtype (Hashable, Binary, NFData) -type FinalPost = FToc : Enriched Stage1Post+toYearMonth :: UTCTime -> YearMonth+toYearMonth = (\(a, b, _) -> YearMonth (a, b)) . toGregorian . utctDay -finalPostJsonFormatRecord :: JsonFormatRecord e FinalPost-finalPostJsonFormatRecord = field textJsonFormat- :& enrichedXJsonFormatRecord stage1PostJsonFormatRecord+fromYearMonth :: YearMonth -> UTCTime+fromYearMonth (YearMonth (y,m)) = UTCTime (fromGregorian y m 1) 0 -finalPostJsonFormat :: JsonFormat e (Record FinalPost)-finalPostJsonFormat = recordJsonFormat finalPostJsonFormatRecord+deriveTagLink :: (Tag -> Text) -> Tag -> Record Link+deriveTagLink f x = C.toSnd (f . Tag) (unTag x) -type IndexPage x = Enriched (FPageLinks : FToc : FTitle : FUrl : FItems x : FPageNo : '[])+instance (Ord (Record xs), RElem FTags xs, RElem FPosted xs) => Ix.Indexable '[Tag, Posted, YearMonth] (Record xs) where+ indices = Ix.ixList (Ix.ixFun (fmap Tag . view fTags))+ (Ix.ixFun (pure . Posted . view fPosted))+ (Ix.ixFun (pure . toYearMonth . view fPosted)) -indexPageJsonFormatRecord :: JsonFormat e (Record x) -> JsonFormatRecord e (IndexPage x)-indexPageJsonFormatRecord x = enrichedXJsonFormatRecord $ field (listJsonFormat linkJsonFormat)- :& field textJsonFormat- :& field textJsonFormat- :& field textJsonFormat- :& field (listJsonFormat x)- :& field integralJsonFormat- :& RNil+mostRecentPosted :: Ix.IsIndexOf Posted ixs => Int -> Ix.IxSet ixs xs -> [xs]+mostRecentPosted x = take x . Ix.toDescList (Proxy @Posted) -type PostIndexPage = IndexPage Stage1Post+asSitemapUrl :: (RElem FUrl xs, RElem FPosted xs) => Text -> Record xs -> SitemapUrl+asSitemapUrl baseUrl x = SitemapUrl {+ sitemapLocation = baseUrl <> view fUrl x+ , sitemapLastModified = Just (view fPosted x)+ , sitemapChangeFrequency = Nothing+ , sitemapPriority = Nothing+} -postIndexPageJsonFormat :: JsonFormat e (Record PostIndexPage)-postIndexPageJsonFormat = recordJsonFormat $ indexPageJsonFormatRecord stage1PostJsonFormat+-- | Convert a Post to an Atom Entry+asAtomEntry :: (RElem FContent xs, RElem FPosted xs, RElem FUrl xs, RElem FTitle xs) => Record xs -> Atom.Entry+asAtomEntry x = (Atom.nullEntry (view fUrl x)+ (Atom.TextString $ view fTitle x)+ (T.pack $ formatTime defaultTimeLocale (iso8601DateFormat Nothing) $ view fPosted x)) {+ Atom.entryContent = Just $ Atom.TextContent (view fContent x)+ } -type MainPage = FRecentPosts Stage1Post : Enriched RawSingle+renderTitleLink :: (Monad m, RElem FTitle xs, RElem FUrl xs) => Record xs -> HtmlT m ()+renderTitleLink = liftA2 renderLink (view fTitle) (view fUrl) -mainPageJsonFormatRecord :: JsonFormatRecord e MainPage-mainPageJsonFormatRecord = field (listJsonFormat stage1PostJsonFormat)- :& enrichedXJsonFormatRecord rawSingleJsonFormatRecord+renderDocNav :: (Monad m, RElem FTitle xs, RElem FUrl xs) => Cofree [] (Record xs) -> HtmlT m ()+renderDocNav xs = ul_ $ li_ $ renderCofree renderTitleLink xs -mainPageJsonFormat :: JsonFormat e (Record MainPage)-mainPageJsonFormat = recordJsonFormat mainPageJsonFormatRecord+renderPageLinks :: (RElem FPageNo xs, RElem FUrl xs, MonadThrow m) => Int -> Zipper [] (Record xs) -> HtmlT m ()+renderPageLinks = renderZipperWithin (liftA2 renderLink (T.pack . show . view fPageNo) (view fUrl)) -addTagLinks :: (MonadAction m, RElem FTags xs) => Record xs -> m (Record (FTagLinks : xs))-addTagLinks xs = do- ks <- forM (view fTags xs) $ \x -> do- u <- askOracle . IndexRoot . ByTag . Tag $ x- return (x :*: u :*: RNil)- return $ ks :*: xs+type BasicFields = FContent+ : FDescription+ : FImage+ : FModified+ : FPosted+ : FSrcPath+ : FTags+ : FTitle+ : FUrl+ : '[] -addTeaser :: RElem FContent xs => Record xs -> Record (FTeaser : xs)-addTeaser xs = head (T.splitOn "<!-- more -->" (view fContent xs)) :*: xs+basicFields :: Rec (JsonField e) BasicFields+basicFields = (field textJsonFormat :: JsonField e FContent)+ :& (field textJsonFormat :: JsonField e FDescription)+ :& (optionalField textJsonFormat :: JsonField e FImage)+ :& (field iso8601DateTimeJsonFormat :: JsonField e FModified)+ :& (field sbShortDateJsonFormat :: JsonField e FPosted)+ :& (field relFileJsonFormat :: JsonField e FSrcPath)+ :& (field (listJsonFormat textJsonFormat) :: JsonField e FTags)+ :& (field textJsonFormat :: JsonField e FTitle)+ :& (field textJsonFormat :: JsonField e FUrl)+ :& RNil -addPrettyDate :: RElem FPosted xs => Record xs -> Record (FPrettyDate : xs)-addPrettyDate xs = view fPosted xs :*: xs+type ExtraFields = FCdnImports+ : FHighlighting+ : FPageLinks+ : FPageNo+ : FPrettyDate+ : FSiteTitle+ : FSocialLinks+ : FTagLinks+ : FTeaser+ : FTocHtml+ : FTocCF+ : '[] +extraFields :: Rec (JsonField e) ExtraFields+extraFields = (field htmlJsonFormat :: JsonField e FCdnImports)+ :& (field styleJsonFormat :: JsonField e FHighlighting)+ :& (field htmlJsonFormat :: JsonField e FPageLinks)+ :& (field integralJsonFormat :: JsonField e FPageNo)+ :& (field sbDisplayDateTimeJsonFormat :: JsonField e FPrettyDate)+ :& (field textJsonFormat :: JsonField e FSiteTitle)+ :& (field (listJsonFormat linkJsonFormat) :: JsonField e FSocialLinks)+ :& (field (listJsonFormat linkJsonFormat) :: JsonField e FTagLinks)+ :& (field textJsonFormat :: JsonField e FTeaser)+ :& (field htmlJsonFormat :: JsonField e FTocHtml)+ :& (field (cofreeListJsonFormat linkJsonFormat) :: JsonField e FTocCF)+ :& RNil -instance Ix.Indexable '[Tag, Posted, YearMonth] (Record Stage1Post) where- indices = Ix.ixList (Ix.ixFun (fmap Tag . view fTags))- (Ix.ixFun (pure . Posted . view fPosted))- (Ix.ixFun (pure . YearMonth . toYearMonthPair . view fPosted))+listCastElemsFormat :: (RMap a, RecordToJsonObject a, RecordFromJson a, a <: b) => JsonFormatRecord e b -> JsonFormat e [Record a]+listCastElemsFormat = listJsonFormat . recordJsonFormat . rcast -newtype BlogNav = BlogNav ()- deriving (Eq, Show, Generic, Binary, Hashable, NFData)+type CompositeFields = FItems (Routed Stage1Post)+ : FSubsections (Routed RawDoc)+ : FRecentPosts (Routed Stage1Post)+ : '[] -type instance RuleResult BlogNav = Text+compositeFields :: Rec (JsonField e) CompositeFields+compositeFields = let x = extraFields <+> basicFields+ in (field (listCastElemsFormat x) :: JsonField e (FItems (Routed Stage1Post)))+ :& (field (listCastElemsFormat x) :: JsonField e (FSubsections (Routed RawDoc)))+ :& (field (listCastElemsFormat x) :: JsonField e (FRecentPosts (Routed Stage1Post)))+ :& RNil -newtype DocNav = DocNav ()- deriving (Eq, Show, Generic, Binary, Hashable, NFData)+type StandardFields = BasicFields ++ ExtraFields ++ CompositeFields -type instance RuleResult DocNav = Text+allFields :: Rec (JsonField e) StandardFields+allFields = basicFields <+> extraFields <+> compositeFields -newtype RecentPosts = RecentPosts ()- deriving (Eq, Show, Generic, Binary, Hashable, NFData)+rawPostMetaJsonFormat :: JsonFormat e (Record RawPostMeta)+rawPostMetaJsonFormat = recordJsonFormat $ rcast basicFields -type instance RuleResult RecentPosts = [Record Stage1Post]+rawDocMetaJsonFormat :: JsonFormat e (Record RawDocMeta)+rawDocMetaJsonFormat = recordJsonFormat $ rcast basicFields -data PostsFilter = AllPosts | ByTag Tag | ByYearMonth YearMonth- deriving (Eq, Show, Generic)+rawSingleMetaJsonFormat :: JsonFormat e (Record RawSingleMeta)+rawSingleMetaJsonFormat = recordJsonFormat $ rcast basicFields -instance NFData PostsFilter-instance Hashable PostsFilter-instance Binary PostsFilter+enrichmentFields :: Rec (JsonField e) Enrichment+enrichmentFields = rcast allFields -newtype IndexRoot = IndexRoot PostsFilter- deriving (Eq, Show, Generic, Binary, Hashable, NFData)+mainPageJsonFields :: Rec (JsonField e) MainPage+mainPageJsonFields = rcast allFields -type instance RuleResult IndexRoot = Text+finalPostJsonFields :: Rec (JsonField e) FinalPost+finalPostJsonFields = rcast allFields -newtype IndexPages = IndexPages PostsFilter- deriving (Eq, Show, Generic, Binary, Hashable, NFData)+finalDocJsonFields :: Rec (JsonField e) FinalDoc+finalDocJsonFields = rcast allFields -type instance RuleResult IndexPages = [Record (FUrl : FItems Stage1Post : FPageNo : '[])]+postIndexPageJsonFields :: Rec (JsonField e) PostIndexPage+postIndexPageJsonFields = rcast allFields -type TMain = "templates/index.html" :-> Record MainPage-type TDoc = "templates/docs.html" :-> Record FinalDoc-type TPost = "templates/post.html" :-> Record FinalPost-type TPostIndex = "templates/post-list.html" :-> Record PostIndexPage+enrichedRecordJsonFormat :: (RMap a, RecordToJsonObject a, RecordFromJson a) => Rec (JsonField e) a -> JsonFormat e (Record (Enrichment ++ a))+enrichedRecordJsonFormat = recordJsonFormat . (enrichmentFields <+>) -indexFilter :: (Indexable ixs a, IsIndexOf Tag ixs,- IsIndexOf YearMonth ixs) =>- PostsFilter -> IxSet ixs a -> IxSet ixs a+type MonadSB r m = (MonadReader r m, HasLogFunc r, MonadUnliftAction m, MonadThrow m) -indexFilter x = case x of- AllPosts -> id- ByTag t -> (Ix.@+ [t])- ByYearMonth t -> (Ix.@+ [t])+indexPagesBy :: (MonadThrow m, Ix.IsIndexOf a ixs) => Proxy a -> Int -> Ix.IxSet ixs (Record xs) -> m (Zipper [] (Record (FItems xs : FPageNo : '[])))+indexPagesBy k i ixset = do+ p <- paginate' i $ Ix.toDescList k ixset+ return $ p =>> \a -> extract a :*: pos a + 1 :*: RNil -defaultIndexRoots :: MonadAction m => IndexRoot -> m Text-defaultIndexRoots (IndexRoot x) = case x of- AllPosts -> return "/posts/"- ByTag (Tag t) -> (<> "tags/" <> t <> "/") <$> askOracle (IndexRoot AllPosts)- ByYearMonth (YearMonth (y, m)) -> (<> "months/" <> defaultMonthUrlFormat (fromYearMonthPair (y, m)) <> "/") <$> askOracle (IndexRoot AllPosts)+createDocNav :: (RElem FTitle xs, RElem FUrl xs) => Cofree [] (Record xs) -> Cofree [] (Record Link)+createDocNav = fmap (C.fanout (view fTitle) (view fUrl)) -defaultIndexPages :: (MonadAction m, MonadThrow m, Indexable xs (Record Stage1Post), IsIndexOf YearMonth xs, IsIndexOf Tag xs, IsIndexOf Posted xs) => IxSet xs (Record Stage1Post) -> Int -> IndexPages -> m [Record (FUrl : FItems Stage1Post : FPageNo : '[])]-defaultIndexPages postIx postsPerPage (IndexPages x) = do- r <- askOracle $ IndexRoot x- let k = Ix.toDescList (Proxy @Posted) . indexFilter x $ postIx- p <- paginate' postsPerPage k- return $ unzipper $ extend (\a -> r <> "pages/" <> T.pack (show $ pos a + 1) :*: extract a :*: pos a + 1:*: RNil) p
src/Shakebook/Defaults.hs view
@@ -1,7 +1,5 @@ {- | Module : Shakebook.Defaults- Copyright : Copyright (C) 2020 Daniel Firth- Maintainer : Daniel Firth <dan.firth@homotopic.tech License : MIT Stability : experimental @@ -9,12 +7,14 @@ -} module Shakebook.Defaults where -import Lucid import Lucid.CDN import RIO+import RIO.List.Partial import qualified RIO.Map as M import qualified RIO.Text as T+import qualified RIO.Text.Partial as T import RIO.Time+import Shakebook.Lucid import Text.DocTemplates import Text.Pandoc.Definition import Text.Pandoc.Highlighting@@ -29,11 +29,8 @@ defaultPrettyTimeFormat :: UTCTime -> Text defaultPrettyTimeFormat = T.pack . formatTime defaultTimeLocale "%A, %B %d, %Y" -defaultMonthUrlFragment :: UTCTime -> Text-defaultMonthUrlFragment t = "/posts/months/" <> defaultMonthUrlFormat t--defaultHighlighting :: Style-defaultHighlighting = pygments+defaultHighlighting :: StyleFragment+defaultHighlighting = toStyleFragment pygments defaultMarkdownReaderOptions :: ReaderOptions defaultMarkdownReaderOptions = def { readerExtensions = pandocExtensions }@@ -52,11 +49,14 @@ defaultVideoReplacement :: Text -> Text -> Inline defaultVideoReplacement baseUrl x = Str $ "[Video available at [" <> baseUrl <> "/" <> x <> "]" -defaultCdnImports :: Html ()-defaultCdnImports = do+defaultDeriveTeaser :: Text -> Text+defaultDeriveTeaser = head . T.splitOn "<!-- more -->"++defaultCdnImports :: HtmlFragment+defaultCdnImports = toHtmlFragment $ do bootstrapCSS_5_0_0_alpha1 bootstrapJS_5_0_0_alpha1 fontawesome_4_7_0- mathjax_3_0_5+ mathjax_3_1_0 jquery_3_5_1 popper_2_4_4
src/Shakebook/Feed.hs view
@@ -1,7 +1,5 @@ {- | Module : Shakebook.Feed- Copyright : Copyright (C) 2020 Daniel Firth- Maintainer : Daniel Firth <dan.firth@homotopic.tech License : MIT Stability : experimental
+ src/Shakebook/IxSet.hs view
@@ -0,0 +1,14 @@+{- |+ Module : Shakebook.IxSet+ License : MIT+ Stability : experimental++-}++module Shakebook.IxSet (+ module Data.IxSet.Typed+, module Data.IxSet.Typed.Conversions+) where++import Data.IxSet.Typed+import Data.IxSet.Typed.Conversions
+ src/Shakebook/Lucid.hs view
@@ -0,0 +1,49 @@+module Shakebook.Lucid where++import Control.Comonad.Cofree+import Control.Comonad.Zipper.Extra+import Data.IxSet.Typed as Ix+import Development.Shake.Plus+import Lucid+import Lucid.Base+import RIO+import RIO.List+import qualified RIO.Text as T+import qualified RIO.Text.Lazy as LT+import Text.Pandoc.Highlighting++newtype HtmlFragment = HtmlFragment { unHtmlFragment :: Text }+ deriving (Eq, Show, Generic, NFData, Binary, Hashable, ToHtml)++toHtmlFragment :: Html () -> HtmlFragment+toHtmlFragment = HtmlFragment . LT.toStrict . renderText++toHtmlFragmentM :: Monad m => HtmlT m () -> m HtmlFragment+toHtmlFragmentM = fmap toHtmlFragment . commuteHtmlT++renderLink :: Monad m => Text -> Text -> HtmlT m ()+renderLink x y = a_ [href_ y] (toHtml x)++renderCofree :: Monad m => (a -> HtmlT m ()) -> Cofree [] a -> HtmlT m ()+renderCofree f (x :< []) = f x+renderCofree f (x :< xs) = f x >> ul_ (forM_ xs (li_ . renderCofree f))++renderZipperWithin :: Monad m => (a -> HtmlT m ()) -> Int -> Zipper [] a -> HtmlT m ()+renderZipperWithin f a xs = mapM_ f (zipperWithin a xs)++renderIxSetGroupDescBy :: (Ord b, Ix.IsIndexOf ix ixs, Monad m)+ => (ix -> HtmlT m ())+ -> (a -> HtmlT m ())+ -> (a -> b)+ -> Ix.IxSet ixs a+ -> HtmlT m ()+renderIxSetGroupDescBy f g h as = ul_ $ forM_ (Ix.groupDescBy as) $ \(y, xs) -> li_ $ do+ f y+ ul_ $ forM_ (sortOn h xs) $ li_ . g++newtype StyleFragment = StyleFragment { unStyleFragment :: Text }+ deriving (Eq, Show, Generic, NFData, Binary, Hashable, ToHtml)++toStyleFragment :: Style -> StyleFragment+toStyleFragment = StyleFragment . T.pack . styleToCss+
src/Shakebook/Mustache.hs view
@@ -1,7 +1,5 @@ {- | Module : Shakebook.Mustahce- Copyright : Copyright (C) 2020 Daniel Firth- Maintainer : Daniel Firth <dan.firth@homotopic.tech License : MIT Stability : experimental @@ -9,38 +7,22 @@ -} module Shakebook.Mustache (- Text.Mustache.Template-, buildPageAction-, buildPageAction'-, compileTemplate'+ renderMustache'+, compileMustacheDir'+, Text.Mustache.PName+, Text.Mustache.Template ) where import Composite.Aeson-import Composite.Record-import Data.Aeson+import Composite.Record import Development.Shake.Plus hiding ((:->))-import GHC.TypeLits (KnownSymbol) import RIO-import qualified RIO.Text as T-import qualified Slick.Mustache-import Text.Mustache---- | Lifted version of `Slick.Mustache.compileTemplate'` with well-typed `Path`.-compileTemplate' :: MonadAction m => Path b File -> m Template-compileTemplate' = liftAction . Slick.Mustache.compileTemplate' . toFilePath+import qualified RIO.Text.Lazy as LT+import qualified Text.Mustache+import Text.Mustache (Template, PName) --- | Build a single page straight from a template.-buildPageAction :: MonadAction m- => Path b File -- ^ The HTML templatate.- -> Value -- ^ A JSON value.- -> Path b' File -- ^ The out filepath.- -> m ()-buildPageAction template value out = do- pageT <- compileTemplate' template- writeFile' out $ substitute pageT value+renderMustache' :: Template -> JsonFormat e (Record a)-> Record a -> Text+renderMustache' t f x = LT.toStrict $ Text.Mustache.renderMustache t (toJsonWithFormat f x) -buildPageAction' :: (MonadAction m, MonadThrow m, KnownSymbol s) => Path Rel Dir -> (s :-> xs) -> JsonFormat e xs -> Path b File -> m ()-buildPageAction' d xs f o = do- let (t, v) = valWithName xs- t' <- parseRelFile $ T.unpack t- buildPageAction (d </> t') (toJsonWithFormat f v) o+compileMustacheDir' :: MonadIO m => PName -> Path b Dir -> m Template+compileMustacheDir' x f = Text.Mustache.compileMustacheDir x (toFilePath f)
src/Shakebook/Pandoc.hs view
@@ -1,53 +1,23 @@ {- | Module : Shakebook.Pandoc- Copyright : Copyright (C) 2020 Daniel Firth- Maintainer : Daniel Firth <dan.firth@homotopic.tech License : MIT Stability : experimental Pandoc utilities lifted to `MonadAction`. -}-module Shakebook.Pandoc (--- * runPandocA- runPandocA-, PandocActionException(..)---- * Readers-, readFilePandoc-, readCSVFile-, readLaTeXFile-, readMarkdownFile-, readMediaWikiFile-, loadMarkdownAsJSON---- * Writers-, makePDFLaTeX---- * File Rules-, needPandocImagesIn---- * Filters-, flattenMeta-, prefixAllImages-, progressivelyDemoteHeaders-, replaceUnusableImages-) where+module Shakebook.Pandoc where import Control.Comonad import Control.Comonad.Cofree-import Data.Aeson-import Data.Aeson.With import Development.Shake.Plus hiding ((:->)) 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.Options import Text.Pandoc.PDF-import Text.Pandoc.Readers import Text.Pandoc.Templates+import Text.Pandoc.Throw import Text.Pandoc.Walk import Text.Pandoc.Writers @@ -57,32 +27,6 @@ instance Exception PandocActionException where displayException (PandocActionException s) = s --- | Natural transformation from `PandocIO` to a `MonadAction`-runPandocA :: (MonadAction m, MonadThrow m) => PandocIO a -> m a-runPandocA p = do- result <- liftIO $ runIO p- either throwM return result---- | Run a Pandoc reader as a Shake action.-readFilePandoc :: (MonadAction m, MonadThrow m) => (ReaderOptions -> Text -> PandocIO Pandoc) -> ReaderOptions -> Path b File -> m Pandoc-readFilePandoc run ropts src = readFile' src >>= runPandocA . run ropts---- | Read a markdown file and return a `Pandoc` as an Action.-readMarkdownFile :: (MonadAction m, MonadThrow m) => ReaderOptions -> Path b File -> m Pandoc-readMarkdownFile = readFilePandoc readMarkdown---- | Read a mediawiki file and return a `Pandoc` as an Action.-readMediaWikiFile :: (MonadAction m, MonadThrow m) => ReaderOptions -> Path b File -> m Pandoc-readMediaWikiFile = readFilePandoc readMediaWiki---- | Read a LaTeX file and return a `Pandoc` as an Action.-readLaTeXFile :: (MonadAction m, MonadThrow m) => ReaderOptions -> Path b File -> m Pandoc-readLaTeXFile = readFilePandoc readLaTeX---- | Read a CSV file and return a `Pandoc` as an Action.-readCSVFile :: (MonadAction m, MonadThrow m) => ReaderOptions -> Path b File -> m Pandoc-readCSVFile = readFilePandoc readCSV- -- | 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 =@@ -94,7 +38,7 @@ -- | Make a pdflatex in an `Action`. makePDFLaTeX :: (MonadAction m, MonadThrow m) => WriterOptions -> Pandoc -> m LBS.ByteString makePDFLaTeX wopts p = do- f <- runPandocA $ do+ f <- runPandocIOThrow $ do t <- compileDefaultTemplate "latex" makePDF "pdflatex" [] writeLaTeX wopts { writerTemplate = Just t } p either (throwM . PandocActionException . show) return f@@ -124,23 +68,3 @@ prefixAllImages dir = walk handleImages where handleImages (Image attr ins (src, txt)) = Image attr ins (T.pack (toFilePath dir) <> "/" <> src, txt) handleImages x = x---- | Flatten a pandoc `Meta` object to a `Value`.-flattenMeta :: MonadAction m => (Pandoc -> PandocIO Text) -> Meta -> m Value-flattenMeta opts meta = liftAction $ Slick.Pandoc.flattenMeta opts meta--{-|- Get a JSON Value of Markdown Data with markdown body as "contents" field- and the srcPath as "srcPath" field.--}-loadMarkdownAsJSON :: (MonadAction m, MonadThrow m)- => ReaderOptions- -> WriterOptions- -> Path b File- -> m Value-loadMarkdownAsJSON ropts wopts srcPath = do- pdoc@(Pandoc meta _) <- readMarkdownFile ropts srcPath- meta' <- flattenMeta (writeHtml5String wopts) meta- outText <- runPandocA $ writeHtml5String wopts pdoc- return $ withStringField "src-path" (T.pack $ toFilePath srcPath)- $ withStringField "content" outText meta'
src/Shakebook/Sitemap.hs view
@@ -1,7 +1,5 @@ {- | Module : Shakebook.Sitemap- Copyright : Copyright (C) 2020 Daniel Firth- Maintainer : Daniel Firth <dan.firth@homotopic.tech> License : MIT Stability : experimental
+ src/Shakebook/Tuple.hs view
@@ -0,0 +1,5 @@+module Shakebook.Tuple (+ module Composite.Record.Tuple+) where++import Composite.Record.Tuple
− src/Shakebook/Utils.hs
@@ -1,14 +0,0 @@-module Shakebook.Utils where--import Data.List.Split-import Path-import RIO--(</$>) :: Functor f => Path b Dir -> f (Path Rel t) -> f (Path b t)-(</$>) d = fmap (d </>)--changeDir :: MonadThrow m => Path b Dir -> Path b' Dir -> Path b t -> m (Path b' t)-changeDir src dst fp = (dst </>) <$> stripProperPrefix src fp--splitPath :: Path b t -> [String]-splitPath = splitOn "/" . toFilePath
test/Spec.hs view
@@ -1,31 +1,28 @@ {-# LANGUAGE TemplateHaskell #-} -import Composite.Record-import qualified Data.IxSet.Typed as Ix-import qualified Data.IxSet.Typed.Conversions as Ix import Data.List.Split-import Data.Text.Time-import Development.Shake.Plus.Extended-import Lucid-import Lucid.Base import Path.Extensions import RIO+import qualified RIO.ByteString.Lazy as LBS import RIO.List-import RIO.List.Partial-import RIO.Partial-import qualified RIO.Text as T-import qualified RIO.Text.Lazy as LT-import Shakebook hiding ((:->))-import Shakebook.Utils+import qualified RIO.Text as T+import Shakebook+import qualified Shakebook.IxSet as Ix+import qualified Shakebook.Tuple as C import Test.Tasty import Test.Tasty.Golden -sourceFolder :: Path Rel Dir-sourceFolder = $(mkRelDir "test/site")+-- Config -- -outputFolder :: Path Rel Dir-outputFolder = $(mkRelDir "test/public")+sourceDir :: Path Rel Dir+sourceDir = $(mkRelDir "test/site") +outputDir :: Path Rel Dir+outputDir = $(mkRelDir "test/public")++templatesDir :: Path Rel Dir+templatesDir = $(mkRelDir "templates")+ baseUrl :: Text baseUrl = "http://blanky.test" @@ -33,149 +30,162 @@ siteTitle = "Blanky Site" tableOfContents :: Cofree [] (Path Rel File)-tableOfContents = $(mkRelFile "docs/index.html") :< [- $(mkRelFile "docs/1/index.html") :< []- , $(mkRelFile "docs/2/index.html") :< [- $(mkRelFile "docs/2/champ.html") :< []+tableOfContents = $(mkRelFile "docs/index.md") :< [+ $(mkRelFile "docs/1/index.md") :< []+ , $(mkRelFile "docs/2/index.md") :< [+ $(mkRelFile "docs/2/champ.md") :< [] ] ] numRecentPosts :: Int numRecentPosts = 3 +numPageNeighbours :: Int+numPageNeighbours = 3+ postsPerPage :: Int postsPerPage = 5 mySocial :: [Record Link]-mySocial = ["twitter" :*: "http://twitter.com/blanky-site-nowhere" :*: RNil- ,"youtube" :*: "http://youtube.com/blanky-site-nowhere" :*: RNil- ,"gitlab" :*: "http://gitlab.com/blanky-site-nowhere" :*: RNil]--addUrl :: (MonadThrow m, RElem FSrcPath xs) => Record xs -> m (Record (FUrl : xs))-addUrl = addDerivedUrl (fmap toGroundedUrl . withHtmlExtension <=< stripProperPrefix sourceFolder)--stage1Post :: (MonadAction m, MonadThrow m) => Record RawPost -> m (Record Stage1Post)-stage1Post = addUrl >=> return . addTeaser >=> addTagLinks >=> return . addPrettyDate--stage1Doc :: MonadThrow m => Record RawDoc -> m (Record Stage1Doc)-stage1Doc = addUrl--enrichPage :: Record x -> Record (Enriched x)-enrichPage x = mySocial :*: (LT.toStrict . renderText $ defaultCdnImports) :*: defaultHighlighting :*: siteTitle :*: x--rules :: ShakePlus SimpleSPlusEnv ()-rules = do+mySocial = [ "twitter" :|: "http://twitter.com/blanky-site-nowhere"+ , "youtube" :|: "http://youtube.com/blanky-site-nowhere"+ , "gitlab" :|: "http://gitlab.com/blanky-site-nowhere"+ ] - readMD <- newCache $ \x -> do- logInfo $ "Loading " <> displayShow (toFilePath x)- loadMarkdownAsJSON defaultMarkdownReaderOptions defaultHtml5WriterOptions x+postsRoot :: Text+postsRoot = "/posts/" - readRawSingle <- newCache $ readMD >=> parseValue' rawSingleJsonFormat- readRawPost <- newCache $ readMD >=> parseValue' rawPostJsonFormat- readRawDoc <- newCache $ readMD >=> parseValue' rawDocJsonFormat+tagRoot :: Tag -> Text+tagRoot x = "/posts/tags/" <> unTag x <> "/" - readStage1Post <- newCache $ readRawPost >=> stage1Post- readStage1Doc <- newCache $ readRawDoc >=> stage1Doc+monthRoot :: YearMonth -> Text+monthRoot x = "/posts/months/" <> (defaultMonthUrlFormat . fromYearMonth $ x) <> "/" - postIx' <- newCache $ \() -> batchLoadIndex' (Proxy @[Tag, Posted, YearMonth]) readStage1Post sourceFolder ["posts/*.md"]+pageRoot :: Text -> Int -> Text+pageRoot x i = x <> "pages/" <> (T.pack . show $ i) <> "/" - void $ addOracle defaultIndexRoots- void $ addOracleCache $ \y -> postIx' () >>= \x -> defaultIndexPages x postsPerPage y+enrichment :: Record Enrichment+enrichment = val @"social" mySocial+ :& val @"cdn-imports" defaultCdnImports+ :& val @"highlighting" defaultHighlighting+ :& val @"site-title" siteTitle+ :& RNil - let correspondingMD = withMdExtension . (sourceFolder </>)- getDoc = correspondingMD >=> readStage1Doc+type PostSet = Ix.IxSet '[Tag, Posted, YearMonth] (Record (Routed Stage1Post)) - void $ addOracleCache $ \(BlogNav ()) -> LT.toStrict . renderText <$> ((commuteHtmlT . genBlogNav "Blog" defaultPrettyMonthFormat) =<< postIx' ())- void $ addOracleCache $ \(DocNav ()) -> LT.toStrict . renderText . genDocNav <$> mapM getDoc tableOfContents- void $ addOracleCache $ \(RecentPosts ()) -> take numRecentPosts . Ix.toDescList (Proxy @Posted) <$> postIx' ()+-- Loaders - "index.html" /%> \(dir, fp) -> do- v <- readRawSingle =<< correspondingMD fp- xs <- askOracle $ RecentPosts ()- let (v' :: TMain) = Val $ xs :*: enrichPage v- buildPageAction' sourceFolder v' mainPageJsonFormat $ dir </> fp+loadMarkdownWith :: (ShakeValue (Record (Compdoc a)), MonadSB r m) => JsonFormat Void (Record a) -> Path Rel File -> m (Record (Compdoc a))+loadMarkdownWith f x = cacheAction ("loader" :: Text, x) $ do+ logInfo $ "Loading " <> displayShow (toFilePath x)+ readMarkdownFile defaultMarkdownReaderOptions defaultHtml5WriterOptions f x - "posts/*.html" /%> \(dir, fp) -> do- src <- correspondingMD fp- xs <- postIx' () >>= Ix.toZipperDesc (Proxy @Posted) >>= seekOnThrow (view fSrcPath) src- nav <- askOracle $ BlogNav ()- let (v :: TPost) = Val $ nav :*: enrichPage (extract xs)- buildPageAction' sourceFolder v finalPostJsonFormat $ dir </> fp+postIndex :: MonadSB r m => Path Rel Dir -> [FilePattern] -> m PostSet+postIndex = batchLoadIndex $ \x -> do+ k <- loadMarkdownWith rawPostMetaJsonFormat x+ u <- deriveUrl x+ return $ u :*: stage1PostExtras k <+> k - sequence_ $ tableOfContents =>> \xs ->- (toFilePath . extract $ xs) /%> \(dir, fp) -> do- nav <- askOracle $ DocNav ()- subs <- mapM getDoc (fmap extract . unwrap $ xs)- v <- getDoc fp- let (v' :: TDoc) = Val $ nav :*: subs :*: enrichPage v- buildPageAction' sourceFolder v' finalDocJsonFormat $ dir </> fp+docTree :: MonadSB r m => Path Rel Dir -> Cofree [] (Path Rel File) -> m (Cofree [] (Record (Routed RawDoc)))+docTree dir toc' = forM (dir </$> toc') $ \x -> do+ k <- loadMarkdownWith rawDocMetaJsonFormat x+ u <- deriveUrl x+ return $ u :*: k - let buildPostIndex title query pageno out = do- nav <- askOracle $ BlogNav ()- xs <- askOracle query- xs' <- zipper' $ sortOn (Down . view fPageNo) xs- let links = fmap (\x -> T.pack (show (view fPageNo x)) :*: view fUrl x :*: RNil) (unzipper xs')- let (v :: TPostIndex) = Val $ enrichPage (links :*: nav :*: title :*: extract (seek (pageno - 1) xs'))- buildPageAction' sourceFolder v postIndexPageJsonFormat out+-- Extras - "posts/pages/*/index.html" /%> \(dir, fp) -> do- let n = read . (!! 2) $ splitPath fp- buildPostIndex "Posts" (IndexPages AllPosts) n $ dir </> fp+deriveUrl :: MonadThrow m => Path Rel File -> m Text+deriveUrl = fmap toGroundedUrl . withHtmlExtension <=< stripProperPrefix sourceDir - "posts/tags/*/pages/*/index.html" /%> \(dir, fp) -> do- let fp' = splitPath fp- let t = T.pack $ fp' !! 2- let n = read $ fp' !! 4- buildPostIndex ("Posts tagged " <> t) (IndexPages (ByTag (Tag t))) n $ dir </> fp+mainPageExtras :: Ix.IsIndexOf Posted ixs => Ix.IxSet ixs (Record xs) -> Record (FRecentPosts xs : '[])+mainPageExtras = C.singleton . mostRecentPosted numRecentPosts - "posts/months/*/pages/*/index.html" /%> \(dir, fp) -> do- let out' = splitPath fp- let t = parseISODateTime $ T.pack $ out' !! 2- let t' = YearMonth $ toYearMonthPair t- let n = read $ out' !! 4- buildPostIndex ("Posts from " <> defaultPrettyMonthFormat t) (IndexPages $ ByYearMonth t') n $ dir </> fp+stage1PostExtras :: Record RawPost -> Record Stage1PostExtras+stage1PostExtras x = view fPosted x+ :*: (map (deriveTagLink tagRoot . Tag) . view fTags $ x)+ :*: (defaultDeriveTeaser . view fContent $ x)+ :*: RNil - ["posts/index.html", "posts/tags/*/index.html", "posts/months/*/index.html"] /|%> \(dir, fp) -> do- copyFileChanged (dir </> parent fp </> $(mkRelFile "pages/1/index.html")) (dir </> fp)+createBlogNav :: PostSet -> Cofree [] (Record Link)+createBlogNav xs = ("Blog" :*: postsRoot :*: RNil)+ :< Ix.toDescCofreeList+ (C.fanout (defaultPrettyMonthFormat . fromYearMonth) monthRoot)+ (C.fanout (view fTitle) (view fUrl))+ (Down . view fPosted)+ xs - ["css//*", "js//*", "webfonts//*", "images//*"] /|%> \(dir, fp) ->- copyFileChanged (sourceFolder </> fp) (dir </> fp)+-- Stache Builders - "sitemap.xml" /%> \(dir, fp) -> do- xs <- postIx' ()- let xs' = Ix.toDescList (Proxy @Posted) xs- buildSitemap (asSitemapUrl baseUrl <$> xs') $ dir </> fp+myBuildPage :: (MonadAction m, RMap x, RecordToJsonObject x, RecordFromJson x)+ => PName -> Rec (JsonField e) x -> Record x -> Path Rel File -> m ()+myBuildPage t f x out = do+ k <- compileMustacheDir' t (sourceDir </> templatesDir)+ let l' = renderMustache' k (enrichedRecordJsonFormat f) (enrichment <+> x)+ writeFile' out l' - let simplePipeline f = getDirectoryFiles sourceFolder >=> mapM f >=> needIn outputFolder- verbatimPipeline = simplePipeline return+buildFromRouteF t f x = do+ out <- fromGroundedUrlF $ view fUrl x+ myBuildPage t f (rcast x) (outputDir </> out) - phony "statics" $ verbatimPipeline ["css//*", "js//*", "webfonts//*", "images//*"]+buildFromRouteD t f x = do+ out <- deriveIndexHtmlF $ view fUrl x+ myBuildPage t f (rcast x) (outputDir </> out) - phony "index" $ needIn outputFolder [$(mkRelFile "index.html")]+-- Rules - phony "docs" $ mapM withHtmlExtension tableOfContents >>= needIn outputFolder+docsRules :: MonadSB r m => Path Rel Dir -> Cofree [] (Path Rel File) -> m ()+docsRules dir toc = do+ as <- docTree dir toc+ let nav = createDocNav as+ let as' = as =>> \(x :< xs) -> val @"toc" nav :& val @"subsections" (extract <$> xs) :& x+ forM_ as' $ buildFromRouteF "docs" finalDocJsonFields - phony "posts" $ simplePipeline withHtmlExtension ["posts/*.md"]+mainPageRules :: MonadSB r m => PostSet -> m ()+mainPageRules postsIx = do+ x <- loadMarkdownWith rawSingleMetaJsonFormat $ sourceDir </> $(mkRelFile "index.md")+ let x' = mainPageExtras postsIx <+> x+ myBuildPage "index" mainPageJsonFields x' $ outputDir </> $(mkRelFile "index.html") - let phonyIndex x = do- k <- askOracle $ IndexRoot x- ps <- askOracle $ IndexPages x- xs <- mapM fromGroundedUrlD $ k : (view fUrl <$> ps)- needIn outputFolder $ fmap (</> $(mkRelFile "index.html")) xs+deriveIndexHtmlF :: MonadThrow m => Text -> m (Path Rel File)+deriveIndexHtmlF = fmap (</> $(mkRelFile "index.html")) . fromGroundedUrlD - phony "post-index" $ do- phonyIndex AllPosts- xs <- postIx' ()- forM_ (Ix.indexKeys xs) $ \t -> phonyIndex $ ByTag t- forM_ (Ix.indexKeys xs) $ \t -> phonyIndex $ ByYearMonth t+postIndexRules :: MonadSB r m => Cofree [] (Record Link) -> Text -> PostSet -> Text -> m ()+postIndexRules nav title postset root = do+ ys <- indexPagesBy (Proxy @Posted) postsPerPage postset+ let ys' = flip fmap ys $ \x -> val @"url" (pageRoot root $ view fPageNo x) :& x+ sequence_ $ ys' =>> \xs' -> do+ let x = extract xs'+ ps <- toHtmlFragmentM $ renderPageLinks numPageNeighbours ys'+ let x' = val @"page-links" ps :& val @"toc" nav :& val @"title" title :& x+ buildFromRouteD "post-list" postIndexPageJsonFields x'+ k' <- deriveIndexHtmlF $ view fUrl $ extract $ seek 0 ys'+ s' <- deriveIndexHtmlF root+ copyFileChanged (outputDir </> k') (outputDir </> s') - phony "clean" $ do- logInfo $ "Cleaning files in " <> displayShow outputFolder- removeFilesAfter outputFolder ["//*"]+postRules :: MonadSB r m => Path Rel Dir -> [FilePattern] -> m PostSet+postRules dir fp = cacheAction ("build" :: T.Text, (dir, fp)) $ do+ postsIx <- postIndex dir fp+ let nav = createBlogNav postsIx+ let postsZ = Ix.toDescList (Proxy @Posted) postsIx+ let postsZ' = fmap (\x -> val @"toc" nav :& x) postsZ+ forM_ postsZ' $ buildFromRouteF "post" finalPostJsonFields+ postIndexRules nav "Posts" postsIx postsRoot+ forM_ (Ix.indexKeys postsIx) $ \t@(Tag t') ->+ postIndexRules nav ("Posts tagged " <> t') (postsIx Ix.@+ [t]) (tagRoot t)+ forM_ (Ix.indexKeys postsIx) \ym@(YearMonth _) ->+ postIndexRules nav ("Posts from " <> defaultPrettyMonthFormat (fromYearMonth ym)) (postsIx Ix.@+ [ym]) (monthRoot ym)+ return postsIx - phony "sitemap" $ needIn outputFolder [$(mkRelFile "sitemap.xml")]+sitemapRules :: MonadSB r m => PostSet -> Path Rel File -> m ()+sitemapRules xs out = cacheAction ("sitemap" :: T.Text, out) $+ LBS.writeFile (toFilePath $ outputDir </> out) $ renderSitemap $ Sitemap $ asSitemapUrl baseUrl <$> Ix.toList xs - phony "all" $ need ["index", "posts", "post-index", "docs", "statics", "sitemap"]+buildRules :: MonadSB r m => m ()+buildRules = do+ xs <- postRules sourceDir ["posts/*.md"]+ mainPageRules xs+ docsRules sourceDir tableOfContents+ sitemapRules xs $(mkRelFile "sitemap.xml") tests :: [FilePath] -> TestTree tests xs = testGroup "Rendering Tests" $@@ -184,6 +194,6 @@ main :: IO () main = do- runSimpleShakePlus outputFolder $ want ["clean"] >> rules- runSimpleShakePlus outputFolder $ want ["all"] >> rules- findByExtension [".html", ".xml"] "test/golden" >>= defaultMain . tests+ let shOpts = shakeOptions { shakeLintInside = ["\\"]}+ runLoggedShakeForward shOpts buildRules+ findByExtension [".html", ".xml"] "test/golden" >>= defaultMain . tests