shakebook 0.6.0.0 → 0.7.0.0
raw patch · 9 files changed
+120/−114 lines, 9 filesdep +ixset-typeddep −ixsetsetup-changed
Dependencies added: ixset-typed
Dependencies removed: ixset
Files
- ChangeLog.md +7/−1
- Setup.hs +0/−2
- shakebook.cabal +4/−5
- src/Shakebook.hs +0/−2
- src/Shakebook/Conventions.hs +44/−12
- src/Shakebook/Data.hs +0/−84
- src/Shakebook/Feed.hs +1/−1
- src/Shakebook/Pandoc.hs +59/−0
- test/Spec.hs +5/−7
ChangeLog.md view
@@ -1,9 +1,15 @@ # Changelog for Shakebook +## (v0.7.0.0)++* Switch to [ixset-typed](httos://hackage.haskell.org/package/ixset-typed).+* Drop `Shakebook.Data` module and move to `Shakebook.Pandoc` and `Shakebook.Conventions`.+* Add `postIndex` function.+ ## (v0.6.0.0) * Drop `Display` instances for `Within` and `Path`.-* Introduce [ixset](https://hackage.haskell.org/package/ixset)+* Introduce [ixset](https://hackage.haskell.org/package/ixset). ## (v0.5.1.0)
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
shakebook.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 04043d969a1442f47c137e5bc16334c189a9fd62153a924984b247d4ed9470f2+-- hash: 7e82312f4be709fd5cf0db5e49335216bd6457f8d8e8d5eb86c75e6d3bdcc29f name: shakebook-version: 0.6.0.0+version: 0.7.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@@ -25,7 +25,6 @@ exposed-modules: Shakebook Shakebook.Conventions- Shakebook.Data Shakebook.Defaults Shakebook.Feed Shakebook.Mustache@@ -45,7 +44,7 @@ , doctemplates , feed , free- , ixset+ , ixset-typed , lens , lens-aeson , mustache@@ -78,7 +77,7 @@ , doctemplates , feed , free- , ixset+ , ixset-typed , lens , lens-aeson , mustache
src/Shakebook.hs view
@@ -6,7 +6,6 @@ , module Data.Aeson , module Development.Shake.Plus , module Shakebook.Conventions-, module Shakebook.Data , module Shakebook.Defaults , module Shakebook.Feed , module Shakebook.Mustache@@ -21,7 +20,6 @@ import Data.Aeson import Development.Shake.Plus import Shakebook.Conventions-import Shakebook.Data import Shakebook.Defaults import Shakebook.Feed import Shakebook.Mustache
src/Shakebook/Conventions.hs view
@@ -3,13 +3,16 @@ module Shakebook.Conventions ( -- * Lenses- viewPostTime+ viewImage+, viewPostTime , viewPostTimeRaw , viewSrcPath , viewTags , viewTitle , viewAllPostTags , viewAllPostTimes+, withBaseUrl+, withFullUrl , withHighlighting , withNext , withPages@@ -43,10 +46,13 @@ , genPageData , genTocNavbarData + -- * Indexing , Post(..) , Tag(..) , Posted(..) , YearMonth(..)+, SrcFile(..)+, postIndex ) where import Control.Comonad.Cofree@@ -56,18 +62,23 @@ import Data.Aeson as A import Data.Aeson.Lens import Data.Aeson.With-import Data.IxSet as Ix+import Data.IxSet.Typed as Ix import Data.Text.Time+import Development.Shake.Plus import RIO hiding (view) import RIO.List import RIO.List.Partial+import qualified RIO.HashMap as HM import qualified RIO.Text as T import qualified RIO.Text.Partial as T import RIO.Time import qualified RIO.Vector as V-import Shakebook.Data+import Shakebook.Pandoc import Text.Pandoc.Highlighting +-- | View the "image" field of a JSON value.+viewImage :: Value -> Text+viewImage = view (key "image" . _String) -- | View the "date" field of a JSON Value as a UTCTime. viewPostTime :: Value -> UTCTime@@ -93,6 +104,14 @@ viewAllPostTimes :: [Value] -> [UTCTime] viewAllPostTimes = fmap viewPostTime +-- | Add "base-url" field from input Text.+withBaseUrl :: Text -> Value -> Value+withBaseUrl = withStringField "base-url"++-- | Add "full-url" field from input Text.+withFullUrl :: Text -> Value -> Value+withFullUrl = withStringField "full-url"+ -- | Add "highlighting-css" field from input Style. withHighlighting :: Style -> Value -> Value withHighlighting = withStringField "highlighting-css" . T.pack . styleToCss@@ -182,34 +201,47 @@ genLinkData :: Text -> Text -> Value genLinkData x u = object ["id" A..= String x, "url" A..= String u] +-- | Indexable Post Type newtype Post = Post { unPost :: Value } deriving (Show, Eq, Ord, Data, Typeable, ToJSON) +-- | Tag indices for a `Post` for use with `IxSet`. newtype Tag = Tag Text deriving (Show, Eq, Ord, Data, Typeable) +-- | Posted index for a `Post` for use with `IxSet`. newtype Posted = Posted UTCTime deriving (Show, Eq, Ord, Data, Typeable) +-- | YearMonth (yyyy, mm) index for a `Post` for use with `IxSet`. newtype YearMonth = YearMonth (Integer, Int) deriving (Show, Eq, Ord, Data, Typeable) +-- | SrcFile index for a `Post` for use with `IxSet`. 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))- ]+instance Indexable '[Tag, Posted, YearMonth, SrcFile] Post where+ indices = ixList (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)) +-- | Take a Value loading function and a filepattern and return an indexable set of Posts.+postIndex :: MonadAction m+ => (Within Rel (Path Rel File) -> m Value)+ -> Within Rel [FilePattern]+ -> m (Ix.IxSet '[Tag, Posted, YearMonth, SrcFile] Post)+postIndex rd fp = do+ xs <- batchLoadWithin' fp rd+ return (Ix.fromList $ Post <$> HM.elems xs)+ -- | Create a blog navbar object for a posts section, with layers "toc1", "toc2", and "toc3".-genBlogNavbarData :: Text -- ^ "Top level title, e.g "Blog"+genBlogNavbarData :: IsIndexOf YearMonth ixs => 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- -> IxSet Post+ -> IxSet ixs Post -> Value genBlogNavbarData a b f g xs = object [ "toc1" A..= object [ "title" A..= String a@@ -219,7 +251,7 @@ 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)) ]+ , "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
− src/Shakebook/Data.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Shakebook.Data where--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 Shakebook.Pandoc-import Text.Pandoc---- | View the "content" field of a JSON value.-viewContent :: Value -> Text-viewContent = view (key "content" . _String)---- | Add "content" field from input Text.-withContent :: Text -> Value -> Value-withContent = withStringField "content"---- | View the "src-path" field of a JSON Value.-viewSrcPath :: Value -> Text-viewSrcPath = view (key "src-path" . _String)---- | Add "src-path" field based on input Text.-withSrcPath :: Text -> Value -> Value-withSrcPath = withStringField "src-path"---- | View the "base-url" of a JSON Value.-viewBaseUrl :: Value -> Text-viewBaseUrl = view (key "base-url" . _String)---- | Add "base-url" field from input Text.-withBaseUrl :: Text -> Value -> Value-withBaseUrl = withStringField "base-url"---- | View the "full-url" of a JSON Value.-viewFullUrl :: Value -> Text-viewFullUrl = view (key "full-url" . _String)---- | Add "full-url" field from input Text.-withFullUrl :: Text -> Value -> Value-withFullUrl = withStringField "full-url"---- | View the "image" field of a JSON vaule.-viewImage :: Value -> Text-viewImage = view (key "image" . _String)---- | View the "url" field of a JSON Value.-viewUrl :: Value -> Text-viewUrl = view (key "url" . _String)---- | Add "url" field from input Text.-withUrl :: Text -> Value -> Value-withUrl = withStringField "url"---- | 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--{-|- 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- -> Within Rel (Path Rel File)- -> m Value-loadMarkdownAsJSON ropts wopts srcPath = do- pdoc@(Pandoc meta _) <- readMDFileWithin ropts srcPath- meta' <- flattenMeta (writeHtml5String wopts) meta- outText <- runPandocA $ writeHtml5String wopts pdoc- supposedUrl <- generateSupposedUrl (extract srcPath)- return $ withContent outText- . withSrcPath (T.pack . toFilePath $ extract srcPath)- . withUrl supposedUrl $ meta'
src/Shakebook/Feed.hs view
@@ -10,7 +10,7 @@ import RIO.List.Partial import qualified RIO.Text.Lazy as TL import Shakebook.Conventions-import Shakebook.Data+import Shakebook.Pandoc import Text.Atom.Feed as Atom import Text.Atom.Feed.Export
src/Shakebook/Pandoc.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+ module Shakebook.Pandoc ( runPandocA , PandocActionException(..)@@ -10,11 +12,19 @@ , replaceUnusableImages , prefixAllImages , flattenMeta+, viewContent+, viewSrcPath+, viewUrl+, loadMarkdownAsJSON ) where +import Control.Comonad import Control.Comonad.Cofree import Data.Aeson+import Data.Aeson.Lens+import Data.Aeson.With import Development.Shake.Plus+import Path.Extensions import RIO import qualified RIO.ByteString.Lazy as LBS import qualified RIO.Text as T@@ -88,10 +98,59 @@ return $ if x `elem` exts then f src else i handleImages x = return x +-- | Prefix all images in a `Pandoc` with a directory. prefixAllImages :: Path Rel Dir -> Pandoc -> Pandoc prefixAllImages dir = walk handleImages where handleImages (Image attr ins (src, txt)) = Image attr ins (T.pack (toFilePath dir) <> "/" <> src, txt) handleImages x = x +-- | 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++-- | View the "content" field of a JSON value.+viewContent :: Value -> Text+viewContent = view (key "content" . _String)++-- | Add "content" field from input Text.+withContent :: Text -> Value -> Value+withContent = withStringField "content"++-- | View the "src-path" field of a JSON Value.+viewSrcPath :: Value -> Text+viewSrcPath = view (key "src-path" . _String)++-- | Add "src-path" field based on input Text.+withSrcPath :: Text -> Value -> Value+withSrcPath = withStringField "src-path"++-- | View the "url" field of a JSON Value.+viewUrl :: Value -> Text+viewUrl = view (key "url" . _String)++-- | Add "url" field from input Text.+withUrl :: Text -> Value -> Value+withUrl = withStringField "url"++-- | 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 "/") </>)++{-|+ 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+ -> Within Rel (Path Rel File)+ -> m Value+loadMarkdownAsJSON ropts wopts srcPath = do+ pdoc@(Pandoc meta _) <- readMDFileWithin ropts srcPath+ meta' <- flattenMeta (writeHtml5String wopts) meta+ outText <- runPandocA $ writeHtml5String wopts pdoc+ supposedUrl <- toGroundedUrl <$> withHtmlExtension (extract srcPath)+ return $ withContent outText+ . withSrcPath (T.pack . toFilePath $ extract srcPath)+ . withUrl supposedUrl $ meta'+
test/Spec.hs view
@@ -2,7 +2,7 @@ import Control.Lens hiding ((:<)) import Data.Aeson.With-import qualified Data.IxSet as Ix+import qualified Data.IxSet.Typed as Ix import Data.List.Split import Path.Extensions import RIO@@ -55,9 +55,7 @@ readMDC <- newCache $ loadMarkdownAsJSON defaultMarkdownReaderOptions defaultHtml5WriterOptions - postsIx <- newCache $ \fp -> do- xs <- batchLoadWithin' fp readMDC- return $ Ix.fromList $ Post <$> HM.elems (defaultEnrichPost <$> xs)+ postsIx <- newCache $ postIndex $ fmap defaultEnrichPost . readMDC getBlogNavbar <- newCache $ \fp -> do xs <- postsIx fp@@ -65,7 +63,7 @@ postsZ <- newCache $ \fp -> do xs <- postsIx fp- let ys = Ix.toDescList (Ix.Proxy :: Ix.Proxy Posted) xs+ let ys = Ix.toDescList (Proxy :: Proxy Posted) xs zs <- ifor ys $ \i v -> do z <- zipper' (unPost <$> ys) return (viewSrcPath (unPost v), seek i z)@@ -77,7 +75,7 @@ blogTagIndexPageData <- newCache $ \fp -> do xs <- postsIx fp- k <- forM (Ix.groupDescBy xs) $ \((Tag t), ys) -> do+ 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@@ -103,7 +101,7 @@ let v' = withHighlighting pygments . withSocialLinks mySocial . withSiteTitle siteTitle- . withRecentPosts (take numRecentPosts $ Ix.toDescList (Ix.Proxy :: Ix.Proxy Posted) rs) $ v+ . withRecentPosts (take numRecentPosts $ Ix.toDescList (Proxy :: Proxy Posted) rs) $ v buildPageActionWithin (s' tmpl) v' out myBuildBlogPage tmpl v out = do