{-# LANGUAGE TemplateHaskell #-}
module Shakebook.Data 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 Development.Shake.Plus
import qualified Development.Shake.FilePath
import Path as P
import RIO hiding (Lens', lens, view)
import qualified RIO.Text as T
import Shakebook.Aeson
import Slick.Pandoc
import Text.Pandoc.Options
import Within
needLocalOut :: (MonadAction m, MonadReader r m, HasLocalOut r) => [Path Rel File] -> m ()
needLocalOut ys = view localOutL >>= \r -> needIn r ys
(%->) :: (MonadReader r m, MonadRules m, HasLocalOut r) => FilePattern -> (Within Rel File -> RAction r ()) -> m ()
(%->) pat f = view localOutL >>= \o -> (toFilePath o Development.Shake.FilePath.</> pat) %> \x -> (x `asWithin` o) >>= f
class HasLocalOut r where
localOutL :: Lens' r (Path Rel Dir)
class HasLocalSrc r where
localSrcL :: Lens' r (Path Rel Dir)
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 t) where
display (WithinDisplay (Within (x,y))) = display (PathDisplay x) <> "[" <> display (PathDisplay y) <> "]"
instance Display [WithinDisplay a t] where
display [] = ""
display (x : xs) = display x <> " : " <> display xs
type ToC = Cofree [] String
data SbConfig = SbConfig
{ sbSrcDir :: Path Rel Dir
, sbOutDir :: Path Rel Dir
, sbBaseUrl :: Text
, sbMdRead :: ReaderOptions
, sbHTWrite :: WriterOptions
, sbPPP :: Int
}
deriving (Show)
class HasSbConfig a where
sbConfigL :: Lens' a SbConfig
data ShakebookEnv = ShakebookEnv
{ logFunc :: LogFunc
, sbConfig :: SbConfig
}
instance HasLocalOut ShakebookEnv where
localOutL = lens (sbOutDir . sbConfig) undefined
instance HasSbConfig ShakebookEnv where
sbConfigL = lens sbConfig undefined
instance HasLogFunc ShakebookEnv where
logFuncL = lens logFunc undefined
viewSrcPath :: Value -> Text
viewSrcPath = view (key "srcPath" . _String)
withSrcPath :: Text -> Value -> Value
withSrcPath = withStringField "srcPath"
withBaseUrl :: Text -> Value -> Value
withBaseUrl = withStringField "baseUrl"
withFullUrl :: Text -> Value -> Value
withFullUrl = withStringField "fullUrl"
viewUrl :: Value -> Text
viewUrl = view (key "url" . _String)
withUrl :: Text -> Value -> Value
withUrl = withStringField "url"
enrichFullUrl :: Text -> Value -> Value
enrichFullUrl base v = withFullUrl (base <> viewUrl v) v
enrichUrl :: (Text -> Text) -> Value -> Value
enrichUrl f v = withUrl (f (viewSrcPath v)) v
leadingSlash :: Path Abs Dir
leadingSlash = $(mkAbsDir "/")
withHtmlExtension :: MonadThrow m => Path Rel File -> m (Path Rel File)
withHtmlExtension = replaceExtension ".html"
withMarkdownExtension :: MonadThrow m => Path Rel File -> m (Path Rel File)
withMarkdownExtension = replaceExtension ".md"
generateSupposedUrl :: MonadThrow m => Path Rel File -> m (Path Abs File)
generateSupposedUrl srcPath = (leadingSlash </>) <$> withHtmlExtension srcPath
enrichSupposedUrl :: (MonadReader r m, HasSbConfig r, MonadThrow m) => Value -> m Value
enrichSupposedUrl v = view sbConfigL >>= \SbConfig{..} -> do
x <- parseRelFile $ T.unpack $ viewSrcPath v
y <- generateSupposedUrl x
return $ withUrl (T.pack . toFilePath $ y) v
readMarkdownFile' :: (MonadReader r m, HasSbConfig r, MonadAction m)
=> Within Rel File
-> m Value
readMarkdownFile' srcPath = view sbConfigL >>= \SbConfig{..} -> liftAction $ do
docContent <- readFile' (fromWithin srcPath)
docData <- markdownToHTMLWithOpts sbMdRead sbHTWrite docContent
supposedUrl <- liftIO $ (leadingSlash </>) <$> withHtmlExtension (whatLiesWithin srcPath)
return $ withSrcPath (T.pack . toFilePath $ whatLiesWithin srcPath)
. withUrl (T.pack . toFilePath $ supposedUrl) $ docData
data PaginationException = EmptyContentsError
deriving (Show, Eq, Typeable)
instance Exception PaginationException where
displayException EmptyContentsError = "Can not create a Zipper of length zero."
paginate' :: MonadThrow m => Int -> [a] -> m (Zipper [] [a])
paginate' n xs = case paginate n xs of
Just x -> return x
Nothing -> throwM EmptyContentsError
lower :: Cofree [] Value -> [Value]
lower (_ :< xs) = extract <$> xs
type MonadShakebook r m = (MonadReader r m, HasSbConfig r, HasLogFunc r, MonadIO m, MonadThrow m, HasLocalOut r)
type MonadShakebookAction r m = (MonadShakebook r m, MonadAction m)
type MonadShakebookRules r m = (MonadShakebook r m, MonadRules m)
loadSortFilterEnrich :: (MonadShakebookAction r m, Ord b)
=> [FilePattern]
-> (Value -> b)
-> (Value -> Bool)
-> (Value -> Value)
-> m [(Within Rel File, Value)]
loadSortFilterEnrich pat s f e = view sbConfigL >>= \SbConfig {..} ->
loadSortFilterApplyW readMarkdownFile' sbSrcDir pat s f e
loadSortEnrich :: (MonadShakebookAction r m, Ord b)
=> [FilePattern]
-> (Value -> b)
-> (Value -> Value)
-> m [(Within Rel File, Value)]
loadSortEnrich pat s = loadSortFilterEnrich pat s (const True)