yogsototh/her.esy.fun
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

starting to work

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

98
Shakefile.hs
View file

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