save

Shakefile.hs

@@ -1,4 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+import Protolude hiding ((*>))
 
 import Development.Shake
 import Development.Shake.Command
@@ -8,8 +11,9 @@ 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)
+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
@@ -20,42 +24,91 @@ main = do
   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
+           }
+
+inlineToText :: PandocMonad m => [Inline] -> m T.Text
+inlineToText inline =
+  Writers.writeAsciiDoc def (Pandoc nullMeta [Plain inline])
+
 buildRules :: Rules ()
 buildRules = do
+  let
+    siteDir = "_site"
+    optimDir = "_optim"
+    build = (</>) siteDir
   phony "clean" $ do
     putInfo "Cleaning files in _site and _optim"
-    removeFilesAfter "_site" ["//*"]
+    removeFilesAfter siteDir ["//*"]
-    removeFilesAfter "_optim" ["//*"]
+    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
 
-  "_site//*.html" %> buildPost
+
+--  "_site//*.html" %> buildPost
 --  buildPosts
 --  allPosts <- buildPosts
 --  buildIndex allPosts
 --  buildFeed allPosts
 --  copyStaticFiles
 
-data Post = Post { postTitle :: T.Text
+-- data Post = Post { postTitle :: T.Text
-                 , postAuthor :: T.Text
+--                  , postAuthor :: T.Text
-                 , postDate :: T.Text
+--                  , postDate :: T.Text
-                 }
+--                  }
-
+-- 
-defaultReaderOpts t =
+-- defaultReaderOpts t =
-  def { readerExtensions = getDefaultExtensions t
+--   def { readerExtensions = getDefaultExtensions t
-      , readerStandalone = True }
+--       , readerStandalone = True }
-
+-- 
-orgToHTML :: T.Text -> PandocPure T.Text
+-- orgToHTML :: T.Text -> PandocPure T.Text
-orgToHTML txt = Readers.readOrg (defaultReaderOpts "org") txt
+-- orgToHTML txt = Readers.readOrg (defaultReaderOpts "org") txt
-  >>= Writers.writeHtml5String def
+--   >>= Writers.writeHtml5String def
-
+-- 
--- | Load a post, process metadata, write it to output, then return the post object
+-- -- | Load a post, process metadata, write it to output, then return the post object
--- Detects changes to either post content or template
+-- -- Detects changes to either post content or template
-buildPost :: FilePath -> Action ()
+-- buildPost :: FilePath -> Action ()
-buildPost out = do
+-- buildPost out = do
-  let org = "src/" <> (dropDirectory1 $ out -<.> "org")
+--   let org = "src/" <> (dropDirectory1 $ out -<.> "org")
-  liftIO . putStrLn $ "Rebuilding post: " <> out
+--   liftIO . putStrLn $ "Rebuilding post: " <> out
-  postContent <- readFile' org
+--   postContent <- readFile' org
-  -- load post content and metadata as JSON blob
+--   -- load post content and metadata as JSON blob
-  let pandocReturn = Pandoc.runPure $ orgToHTML . T.pack $ postContent
+--   let pandocReturn = Pandoc.runPure $ orgToHTML . T.pack $ postContent
-  case pandocReturn of
+--   case pandocReturn of
-    Left _ -> putError "BAD"
+--     Left _ -> putError "BAD"
-    Right outData -> writeFile' out (T.unpack outData)
+--     Right outData -> writeFile' out (T.unpack outData)

shell.nix

@@ -1,11 +1,13 @@
 { pkgs ? import (fetchTarball https://github.com/NixOS/nixpkgs/archive/20.03.tar.gz) {} }:
 let
+  pkgs1909 = import (fetchTarball https://github.com/NixOS/nixpkgs/archive/19.09.tar.gz) {};
   haskellDeps = ps : with ps; [
     shake
     pandoc
     data-default
+    protolude
+    pkgs1909.haskellPackages.sws
   ];
-  pkgs1909 = import (fetchTarball https://github.com/NixOS/nixpkgs/archive/19.09.tar.gz) {};
   ghc = pkgs.haskellPackages.ghcWithPackages haskellDeps;
 in
 pkgs.mkShell {
@@ -21,7 +23,6 @@ pkgs.mkShell {
         ghc
         git
         direnv
-        pkgs1909.haskellPackages.sws
         haskellPackages.shake
       ];
   }