module Shakebook.Conventions (
viewContent
, viewPostTime
, viewPostTimeRaw
, viewSrcPath
, viewTags
, viewTitle
, viewAllPostTags
, viewAllPostTimes
, withHighlighting
, withNext
, withPages
, withPrettyDate
, withPrevious
, withPosts
, withRecentPosts
, withSrcPath
, withSubsections
, withTagIndex
, withTagLinks
, withTeaser
, withTitle
, enrichPrettyDate
, enrichTagLinks
, enrichTeaser
, extendNext
, extendPrevious
, extendNextPrevious
, extendPageNeighbours
, genBlogNavbarData
, genIndexPageData
, genLinkData
, genPageData
, genTocNavbarData
, dateSortPosts
, monthFilterPosts
, sameMonth
, tagFilterPosts
) where
import Control.Comonad.Cofree
import Control.Comonad.Store
import Control.Comonad.Zipper.Extra
import Control.Lens hiding ((:<))
import Control.Monad.Extra
import Data.Aeson as A
import Data.Aeson.Lens
import Data.Text.Time
import RIO hiding (view)
import RIO.List
import RIO.List.Partial
import qualified RIO.Text as T
import qualified RIO.Text.Partial as T
import RIO.Time
import qualified RIO.Vector as V
import Shakebook.Aeson
import Shakebook.Data
import Text.Pandoc.Highlighting
viewContent :: Value -> Text
viewContent = view (key "content" . _String)
viewPostTime :: Value -> UTCTime
viewPostTime = parseISODateTime . view (key "date" . _String)
viewPostTimeRaw :: Value -> Text
viewPostTimeRaw = view (key "date" . _String)
viewTags :: Value -> [Text]
viewTags = toListOf (key "tags" . values . _String)
viewTitle :: Value -> Text
viewTitle = view (key "title" . _String)
viewAllPostTags :: [Value] -> [Text]
viewAllPostTags = (>>= viewTags)
viewAllPostTimes :: [Value] -> [UTCTime]
viewAllPostTimes = fmap viewPostTime
withHighlighting :: Style -> Value -> Value
withHighlighting = withStringField "highlighting-css" . T.pack . styleToCss
withNext :: Maybe Value -> (Value -> Value)
withNext = withObjectFieldMaybe "next"
withPages :: [Value] -> (Value -> Value)
withPages = withArrayField "pages"
withPrettyDate :: Text -> Value -> Value
withPrettyDate = withStringField "prettydate"
withPrevious :: Maybe Value -> (Value -> Value)
withPrevious = withObjectFieldMaybe "previous"
withPosts :: [Value] -> Value -> Value
withPosts = withArrayField "posts"
withRecentPosts :: [Value] -> Value -> Value
withRecentPosts = withArrayField "recent-posts"
withSubsections :: [Value] -> (Value -> Value)
withSubsections = withArrayField "subsections"
withTagIndex :: [Value] -> Value -> Value
withTagIndex = withArrayField "tagindex"
withTagLinks :: [Value] -> Value -> Value
withTagLinks = withArrayField "taglinks"
withTeaser :: Text -> Value -> Value
withTeaser = withStringField "teaser"
withTitle :: Text -> Value -> Value
withTitle = withStringField "title"
enrichPrettyDate :: (UTCTime -> String) -> Value -> Value
enrichPrettyDate f v = withPrettyDate (T.pack . f . viewPostTime $ v) v
enrichTagLinks :: (Text -> Text) -> Value -> Value
enrichTagLinks f v = withTagLinks ((`genLinkData` f) <$> viewTags v) v
enrichTeaser :: Text -> Value -> Value
enrichTeaser s v = withTeaser (head (T.splitOn s (viewContent v))) v
extendNextPrevious :: Zipper [] Value -> Zipper [] Value
extendNextPrevious = extendPrevious . extendNext
extendPrevious :: Zipper [] Value -> Zipper [] Value
extendPrevious = extend (liftA2 withPrevious zipperPreviousMaybe extract)
extendNext :: Zipper [] Value -> Zipper [] Value
extendNext = extend (liftA2 withNext zipperNextMaybe extract)
extendPageNeighbours :: Int -> Zipper [] Value -> Zipper [] Value
extendPageNeighbours r = extend (liftA2 withPages (zipperWithin r) extract)
genLinkData :: Text -> (Text -> Text) -> Value
genLinkData x f = object ["id" A..= String x, "url" A..= String (f x)]
tagFilterPosts :: Text -> [Value] -> [Value]
tagFilterPosts tag = filter (elem tag . viewTags)
dateSortPosts :: [Value] -> [Value]
dateSortPosts = sortOn (Down . viewPostTime)
sameMonth :: UTCTime -> UTCTime -> Bool
sameMonth a b = y1 == y2 && m1 == m2 where
(y1, m1, _) = f a
(y2, m2, _) = f b
f = toGregorian . utctDay
monthFilterPosts :: UTCTime -> [Value] -> [Value]
monthFilterPosts time = filter (sameMonth time . viewPostTime)
partitionToMonths :: [Value] -> [[Value]]
partitionToMonths = groupBy (on sameMonth viewPostTime) . dateSortPosts
genBlogNavbarData :: Text
-> Text
-> (UTCTime -> Text)
-> (UTCTime -> Text)
-> [Value]
-> 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 (partitionToMonths xs)) ]
] where
toc2 [] = object []
toc2 t@(x : _) = object [ "title" A..= String (f (viewPostTime x))
, "url" A..= String (g (viewPostTime x))
, "toc3" A..= Array (V.fromList t) ]
genTocNavbarData :: Cofree [] Value -> Value
genTocNavbarData (x :< xs) =
object ["toc1" A..= [_Object . at "toc2" ?~ Array (V.fromList $ map toc2 xs) $ x]] where
toc2 (y :< ys) = (_Object . at "toc3" ?~ Array (V.fromList $ map extract ys)) y
genPageData :: Text -> (Text -> Text) -> Zipper [] [Value] -> Value
genPageData t f xs = withTitle t
. withJSON (genLinkData (T.pack . show $ pos xs + 1) f)
. withPosts (extract xs) $ Object mempty
genIndexPageData :: MonadThrow m
=> [Value]
-> Text
-> (Text -> Text)
-> Int
-> m (Zipper [] Value)
genIndexPageData xs g h n = extend (genPageData g h) <$> paginate' n xs