starting to work

This commit is contained in:
Yann Esposito (Yogsototh) 2020-06-22 11:44:11 +02:00
parent 1eb4a6de5a
commit e3a33d9ecf
Signed by untrusted user who does not match committer: yogsototh
GPG Key ID: 7B19A4C650D59646
1 changed files with 83 additions and 59 deletions

View File

@ -1,83 +1,107 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
import Protolude hiding ((*>))
import Protolude
import Development.Shake
import Development.Shake.Command
import Development.Shake.FilePath
import Development.Shake.Util
import Development.Shake
import Development.Shake.Command
import Development.Shake.FilePath
import Development.Shake.Util
import Data.Default (Default(def))
import qualified Data.Set as Set
import qualified Data.Text as T
import Text.Pandoc.Class (PandocPure,PandocMonad)
import qualified Text.Pandoc.Class as Pandoc
import Text.Pandoc.Definition (Pandoc(..),Block(..),Inline,nullMeta,docTitle,docDate,docAuthors)
import Text.Pandoc.Extensions (getDefaultExtensions)
import Text.Pandoc.Options (ReaderOptions(..),TrackChanges(RejectChanges))
import qualified Text.Pandoc.Readers as Readers
import qualified Text.Pandoc.Writers as Writers
import Control.Monad.Fail
import Data.Default ( Default(def) )
import qualified Data.Set as Set
import qualified Data.Text as T
import Text.Pandoc.Class ( PandocPure
, PandocMonad
)
import qualified Text.Pandoc.Class as Pandoc
import Text.Pandoc.Definition ( Pandoc(..)
, Block(..)
, Inline
, nullMeta
, docTitle
, docDate
, docAuthors
)
import Text.Pandoc.Extensions ( getDefaultExtensions )
import Text.Pandoc.Options ( ReaderOptions(..)
, TrackChanges(RejectChanges)
)
import qualified Text.Pandoc.Readers as Readers
import qualified Text.Pandoc.Writers as Writers
main :: IO ()
main = do
let shOpts = shakeOptions { shakeVerbosity = Chatty, shakeLintInside = ["\\"] }
shakeArgs shOpts buildRules
let
shOpts = shakeOptions { shakeVerbosity = Chatty
, shakeLintInside = ["\\"]
}
shakeArgs shOpts buildRules
data BlogPost =
BlogPost { postTitle :: T.Text
, postDate :: T.Text
, postAuthors :: [T.Text]
, postUrl :: FilePath
, postP :: Pandoc
, postBody :: Pandoc
}
inlineToText :: PandocMonad m => [Inline] -> m T.Text
inlineToText inline =
Writers.writeAsciiDoc def (Pandoc nullMeta [Plain inline])
Writers.writeAsciiDoc def (Pandoc nullMeta [Plain inline])
getBlogpostFromMetas
:: (MonadIO m, MonadFail m) => [Char] -> Pandoc -> m BlogPost
getBlogpostFromMetas path pandoc@(Pandoc meta _) = do
eitherBlogpost <- liftIO $ Pandoc.runIO $ do
title <- inlineToText $ docTitle meta
date <- inlineToText $ docDate meta
authors <- mapM inlineToText $ docAuthors meta
-- let url = dropExtension path
return $ BlogPost title date authors path pandoc
case eitherBlogpost of
Left _ -> fail "BAD"
Right bp -> return bp
sortByPostDate :: [BlogPost] -> [BlogPost]
sortByPostDate =
sortBy (\a b -> compare (Down (postDate a)) (Down (postDate b)))
buildRules :: Rules ()
buildRules = do
let
siteDir = "_site"
optimDir = "_optim"
build = (</>) siteDir
phony "clean" $ do
putInfo "Cleaning files in _site and _optim"
removeFilesAfter siteDir ["//*"]
removeFilesAfter optimDir ["//*"]
getPost <- newCache $ \path -> do
fileContent <- readFile' path
eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg def (T.pack fileContent)
case eitherResult of
Left _ -> liftIO $ putText "Problem"
Right pandoc@(Pandoc meta _) -> liftIO $ Pandoc.runIO $ do
title <- inlineToText $ docTitle meta
date <- inlineToText $ docDate meta
authors <- map inlineToText $ docAuthors meta
let url = dropExtension path
return $ BlogPost title date authors url pandoc
getPosts <- newCache $ \() ->
mapM getPost =<< getDirectoryFiles "" ["src/posts//*.org"]
let hsDeps = return ["AsciiArt.hs", "Index.hs", "Rot13.hs"]
cssDeps = map (siteDir </>) <$> getDirectoryFiles "" ["src/css/*.css"]
build "index.html" *> \out -> do
hs <- hsDeps
css <- cssDeps
posts <- getPosts ()
need $ hs
<> css
<> map ( combine "build"
. flip combine "index.html"
. postUrl ) posts
<> [build "atom.xml"]
writeFile' out
. renderHtml . index ""
. sortBy (\a b ->
compare (Down (postDate a)) (Down (postDate b)))
$ posts
build "src/css/*.css" *> \out ->
copyFile' (dropDirectory1 out) out
let siteDir = "_site"
optimDir = "_optim"
build = (</>) siteDir
phony "clean" $ do
putInfo "Cleaning files in _site and _optim"
removeFilesAfter siteDir ["//*"]
removeFilesAfter optimDir ["//*"]
getPost <- newCache $ \path -> do
fileContent <- readFile' path
eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg
def
(T.pack fileContent)
case eitherResult of
Left _ -> fail "BAD"
Right pandoc -> getBlogpostFromMetas path pandoc
getPosts <-
newCache
$ \() -> mapM getPost =<< getDirectoryFiles
""
["src/posts//*.org"]
let -- hsDeps = return ["AsciiArt.hs", "Index.hs", "Rot13.hs"]
cssDeps = map (siteDir </>)
<$> getDirectoryFiles "" ["src/css/*.css"]
build "index.html" %> \out -> do
-- hs <- hsDeps
css <- cssDeps
posts <- getPosts ()
need $ css <> map postUrl posts
-- <> [build "atom.xml"]
let titles = map postTitle posts
writeFile' out (mconcat (map T.unpack titles))
build "src/css/*.css" %> \out -> copyFile' (dropDirectory1 out) out
-- "_site//*.html" %> buildPost