{-# LANGUAGE TemplateHaskell #-}
module Shakebook.Data where
import Control.Comonad.Env as E
import Control.Comonad.Cofree
import Control.Lens hiding ((:<))
import Control.Monad.Extra
import Data.Aeson as A
import Data.Aeson.Lens
import Data.Aeson.With
import Development.Shake.Plus
import Path as P
import RIO hiding (Lens', lens, view)
import qualified RIO.Text as T
import Shakebook.Pandoc
import Slick.Pandoc
import Text.Pandoc
import Within
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 t => Display (WithinDisplay a t) where
display (WithinDisplay (WithinT (EnvT e (Identity a)))) = display (PathDisplay e) <> "[" <> display a <> "]"
instance Display t => Display [WithinDisplay a t] where
display [] = ""
display (x : xs) = display x <> " : " <> display xs
data SbConfig = SbConfig
{ sbSrcDir :: Path Rel Dir
, sbOutDir :: Path Rel Dir
, sbBaseUrl :: Text
, sbMdRead :: ReaderOptions
, sbHTWrite :: WriterOptions
, sbPPP :: Int
, sbGlobalApply :: Value -> Value
}
data ShakebookEnv = ShakebookEnv
{ logFunc :: LogFunc
, sbConfig :: SbConfig
}
class HasSbConfig a where
sbConfigL :: Lens' a SbConfig
instance HasSbConfig ShakebookEnv where
sbConfigL = lens sbConfig undefined
instance HasLogFunc ShakebookEnv where
logFuncL = lens logFunc undefined
viewSrcPath :: Value -> Text
viewSrcPath = view (key "src-path" . _String)
withSrcPath :: Text -> Value -> Value
withSrcPath = withStringField "src-path"
viewBaseUrl :: Value -> Text
viewBaseUrl = view (key "base-url" . _String)
withBaseUrl :: Text -> Value -> Value
withBaseUrl = withStringField "base-url"
viewFullUrl :: Value -> Text
viewFullUrl = view (key "full-url" . _String)
withFullUrl :: Text -> Value -> Value
withFullUrl = withStringField "full-url"
viewImage :: Value -> Text
viewImage = view (key "image" . _String)
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"
withHaskellExtension :: MonadThrow m => Path Rel File -> m (Path Rel File)
withHaskellExtension = replaceExtension ".hs"
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
loadMarkdownAsJSON :: (MonadReader r m, HasSbConfig r, MonadAction m, MonadThrow m)
=> Within Rel (Path Rel File)
-> m Value
loadMarkdownAsJSON srcPath = view sbConfigL >>= \SbConfig{..} -> do
pdoc@(Pandoc meta _) <- readMDFileWithin sbMdRead srcPath
meta' <- liftAction $ flattenMeta (writeHtml5String sbHTWrite) meta
needPandocImagesIn sbOutDir pdoc
outText <- runPandocA $ writeHtml5String sbHTWrite pdoc
let docData = meta' & _Object . at "content" ?~ String outText
supposedUrl <- liftIO $ (leadingSlash </>) <$> withHtmlExtension (extract srcPath)
return $ sbGlobalApply
. withSrcPath (T.pack . toFilePath $ extract srcPath)
. withUrl (T.pack . toFilePath $ supposedUrl) $ docData
immediateShoots :: Cofree [] a -> [a]
immediateShoots(_ :< xs) = extract <$> xs