starting to work
This commit is contained in:
parent
1eb4a6de5a
commit
e3a33d9ecf
1 changed files with 83 additions and 59 deletions
142
Shakefile.hs
142
Shakefile.hs
|
@ -1,83 +1,107 @@
|
||||||
{-# 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 qualified Data.Set as Set
|
import Data.Default ( Default(def) )
|
||||||
import qualified Data.Text as T
|
import qualified Data.Set as Set
|
||||||
import Text.Pandoc.Class (PandocPure,PandocMonad)
|
import qualified Data.Text as T
|
||||||
import qualified Text.Pandoc.Class as Pandoc
|
import Text.Pandoc.Class ( PandocPure
|
||||||
import Text.Pandoc.Definition (Pandoc(..),Block(..),Inline,nullMeta,docTitle,docDate,docAuthors)
|
, PandocMonad
|
||||||
import Text.Pandoc.Extensions (getDefaultExtensions)
|
)
|
||||||
import Text.Pandoc.Options (ReaderOptions(..),TrackChanges(RejectChanges))
|
import qualified Text.Pandoc.Class as Pandoc
|
||||||
import qualified Text.Pandoc.Readers as Readers
|
import Text.Pandoc.Definition ( Pandoc(..)
|
||||||
import qualified Text.Pandoc.Writers as Writers
|
, 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 :: IO ()
|
||||||
main = do
|
main = do
|
||||||
let shOpts = shakeOptions { shakeVerbosity = Chatty, shakeLintInside = ["\\"] }
|
let
|
||||||
shakeArgs shOpts buildRules
|
shOpts = shakeOptions { shakeVerbosity = Chatty
|
||||||
|
, shakeLintInside = ["\\"]
|
||||||
|
}
|
||||||
|
shakeArgs shOpts buildRules
|
||||||
|
|
||||||
data BlogPost =
|
data BlogPost =
|
||||||
BlogPost { postTitle :: T.Text
|
BlogPost { postTitle :: T.Text
|
||||||
, 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
|
putInfo "Cleaning files in _site and _optim"
|
||||||
putInfo "Cleaning files in _site and _optim"
|
removeFilesAfter siteDir ["//*"]
|
||||||
removeFilesAfter siteDir ["//*"]
|
removeFilesAfter optimDir ["//*"]
|
||||||
removeFilesAfter optimDir ["//*"]
|
getPost <- newCache $ \path -> do
|
||||||
getPost <- newCache $ \path -> do
|
fileContent <- readFile' path
|
||||||
fileContent <- readFile' path
|
eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg
|
||||||
eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg def (T.pack fileContent)
|
def
|
||||||
case eitherResult of
|
(T.pack fileContent)
|
||||||
Left _ -> liftIO $ putText "Problem"
|
case eitherResult of
|
||||||
Right pandoc@(Pandoc meta _) -> liftIO $ Pandoc.runIO $ do
|
Left _ -> fail "BAD"
|
||||||
title <- inlineToText $ docTitle meta
|
Right pandoc -> getBlogpostFromMetas path pandoc
|
||||||
date <- inlineToText $ docDate meta
|
getPosts <-
|
||||||
authors <- map inlineToText $ docAuthors meta
|
newCache
|
||||||
let url = dropExtension path
|
$ \() -> mapM getPost =<< getDirectoryFiles
|
||||||
return $ BlogPost title date authors url pandoc
|
""
|
||||||
getPosts <- newCache $ \() ->
|
["src/posts//*.org"]
|
||||||
mapM getPost =<< getDirectoryFiles "" ["src/posts//*.org"]
|
let -- hsDeps = return ["AsciiArt.hs", "Index.hs", "Rot13.hs"]
|
||||||
let hsDeps = return ["AsciiArt.hs", "Index.hs", "Rot13.hs"]
|
cssDeps = map (siteDir </>)
|
||||||
cssDeps = map (siteDir </>) <$> getDirectoryFiles "" ["src/css/*.css"]
|
<$> 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
|
||||||
|
|
Loading…
Reference in a new issue