Fixes

Shakefile.hs

@@ -6,33 +6,28 @@ import           Protolude
 import           Development.Shake
 import           Development.Shake.Command
 import           Development.Shake.FilePath
-import           Development.Shake.Util
 
 import           Control.Monad.Fail
 import           Data.Aeson
-import Text.Megaparsec
+-- import qualified Text.Megaparsec as Megaparsec
 import           Data.Default ( Default(def) )
-import qualified Data.Set as Set
 import qualified Data.Text as T
 import           Text.Mustache
-import           Text.Pandoc.Class ( PandocPure, PandocMonad)
+import           Text.Pandoc.Class (PandocMonad)
 import qualified Text.Pandoc.Class as Pandoc
 import           Text.Pandoc.Definition ( Pandoc(..)
                                         , Block(..)
                                         , Inline
                                         , nullMeta
                                         , docTitle
-                                        , lookupMeta
                                         , docDate
                                         , docAuthors
                                         )
-import           Text.Pandoc.Extensions ( getDefaultExtensions )
 import           Text.Pandoc.Options ( ReaderOptions(..)
                                      , WriterOptions(..)
-                                     , TrackChanges(RejectChanges)
+                                     , ObfuscationMethod(..)
                                      )
 import qualified Text.Pandoc.Readers as Readers
-import qualified Text.Pandoc.Templates as PandocTemplates
 import qualified Text.Pandoc.Writers as Writers
 
 main :: IO ()
@@ -47,6 +42,9 @@ main = shakeArgs shOpts buildRules
 -- Configuration
 -- Should probably go in a Reader Monad
 
+srcDir :: FilePath
+srcDir = "src"
+
 siteDir :: FilePath
 siteDir  = "_site"
 
@@ -82,57 +80,115 @@ getBlogpostFromMetas path toc pandoc@(Pandoc meta _) = do
 
 sortByPostDate :: [BlogPost] -> [BlogPost]
 sortByPostDate =
-        sortBy (\b a -> compare (Down (postDate a)) (Down (postDate b)))
+        sortBy (\a b-> compare (Down (postDate a)) (Down (postDate b)))
 
 
 build :: FilePath -> FilePath
 build = (</>) siteDir
 
+genAllDeps :: [FilePattern] -> Action [FilePath]
+genAllDeps patterns = do
+  allMatchedFiles <- getDirectoryFiles srcDir patterns
+  allMatchedFiles &
+    filter ((/= "html") . takeExtension) &
+    filter (null . takeExtension) &
+    map (siteDir </>)  &
+    return
+
 buildRules :: Rules ()
 buildRules = do
-        cleanRule
+  cleanRule
-        allRule
+  -- build "//*" %> copy
-        getPost <- mkGetPost
+  allRule
-        getPosts <- mkGetPosts getPost
+  getPost <- mkGetPost
-        getTemplate <- mkGetTemplate
+  getPosts <- mkGetPosts getPost
-        let cssDeps = map (siteDir </>) <$> getDirectoryFiles "src" ["css/*.css"]
+  getTemplate <- mkGetTemplate
-            -- templateDeps = getDirectoryFiles "templates" ["*.mustache"]
+  alternatives $ do
-        build "//*.html" %> \out -> do
+    -- build "articles.html" %> \out -> do
-          css <- cssDeps
+    --         css   <- genAllDeps ["//*.css"]
-          -- templates <- templateDeps
+    --         posts <- getPosts ()
-          template <- getTemplate ("templates" </> "main.mustache")
+    --         need $ css <> map postUrl (sortByPostDate posts)
-          let srcFile = "src" </> (dropDirectory1 (replaceExtension out "org"))
+    --         let titles = toS $ T.intercalate "\n" $ map postTitle posts
-          liftIO $ putText $ "need: " <> (toS srcFile) <> " <- " <> (toS out)
+    --         writeFile' out titles
-          need $ css <> [srcFile]
+    build "//*.html" %> genHtmlAction getPost getTemplate
-          bp <- getPost srcFile
+    -- build "//*.org" %> copy
-          eitherHtml <- liftIO $ Pandoc.runIO $ Writers.writeHtml5String (def { writerTableOfContents = (postToc bp) }) (postBody bp)
+    -- build "//*.jpg" %> copy
-          case eitherHtml of
+
-            Left _ -> fail "BAD"
+copy :: FilePath -> Action ()
-            Right innerHtml ->
+copy out = do
-              let htmlContent = renderMustache template $ object [ "title" .= postTitle bp
+  let src = srcDir </> (dropDirectory1 out)
-                                                                 , "authors" .= postAuthors bp
+  copyFileChanged src out
-                                                                 , "date" .= postDate bp
+
-                                                                 , "body" .= innerHtml
+genHtml :: (MonadIO m, MonadFail m) => BlogPost -> m Text
-                                                                 ]
+genHtml bp = do
-              in writeFile' out (toS htmlContent)
+  eitherHtml <- liftIO $
-        build "articles.html" %> \out -> do
+    Pandoc.runIO $
-                css   <- cssDeps
+      Writers.writeHtml5String
-                posts <- getPosts ()
+        (def { writerTableOfContents = (postToc bp)
-                need $ css <> map postUrl (sortByPostDate  posts)
+             , writerEmailObfuscation = ReferenceObfuscation
-                let titles = toS $ T.intercalate "\n" $ map postTitle posts
+             })
-                writeFile' out titles
+        (postBody bp)
-        build "css/*.css" %> \out -> do
+  case eitherHtml of
-          let src = "src" </> (dropDirectory1 out)
+    Left _ -> fail "BAD"
-              dst = out
+    Right innerHtml -> return innerHtml
-          liftIO $ putText $ toS $ "src:" <> src <> " => dst: " <> dst
+
-          copyFile' src dst
+genHtmlAction
+  :: (FilePath -> Action BlogPost)
+     -> (FilePath -> Action Template) -> [Char] -> Action ()
+genHtmlAction getPost getTemplate out = do
+  template <- getTemplate ("templates" </> "main.mustache")
+  let srcFile = srcDir </> (dropDirectory1 (out -<.> "org"))
+  liftIO $ putText $ "need: " <> (toS srcFile) <> " -> " <> (toS out)
+  need [srcFile]
+  bp <- getPost srcFile
+  innerHtml <- genHtml bp
+  let htmlContent =
+        renderMustache template $ object [ "title" .= postTitle bp
+                                         , "authors" .= postAuthors bp
+                                         , "date" .= postDate bp
+                                         , "body" .= innerHtml
+                                         ]
+  writeFile' out (toS htmlContent)
+
+allHtmlAction :: Action ()
+allHtmlAction = do
+    allOrgFiles <- getDirectoryFiles srcDir ["//*.org"]
+    let allHtmlFiles = map (-<.> "html") allOrgFiles
+    need (map build (allHtmlFiles
+                     -- <> ["articles.html"]
+                    ))
+
+compressImage :: CmdResult b => FilePath -> Action b
+compressImage img = do
+  let src = srcDir </> img
+      dst = siteDir </> img
+  need [src]
+  let dir = takeDirectory dst
+  dirExists <- doesDirectoryExist dir
+  when (not dirExists) $
+    command [] "mkdir" ["-p", dir]
+  command [] "convert" [src
+                       , "-strip"
+                       , "-resize","320x320>"
+                       , "-interlace","Plane"
+                       , "-quality","85"
+                       , "-define","filter:blur=0.75"
+                       , "-filter","Gaussian"
+                       , "-ordered-dither","o4x4,4"
+                       , dst ]
 
 allRule :: Rules ()
 allRule =
   phony "all" $ do
-    allOrgFiles <- getDirectoryFiles "src" ["//*.org"]
+    allAssets <- filter (/= ".DS_Store") <$> getDirectoryFiles srcDir ["//*.*"]
-    let allHtmlFiles = map (flip replaceExtension "html") allOrgFiles
+    forM_ allAssets $ \asset ->
-    need (map build (allHtmlFiles <> ["index.html", "articles.html"]))
+      case (takeExtension asset) of
+        ".jpg" -> compressImage asset
+        ".jpeg" -> compressImage asset
+        ".gif" -> compressImage asset
+        ".png" -> compressImage asset
+        _ -> copyFileChanged (srcDir </> asset) (siteDir </> asset)
+    allHtmlAction
 
 cleanRule :: Rules ()
 cleanRule =
@@ -161,7 +217,7 @@ mkGetPost :: Rules (FilePath -> Action BlogPost)
 mkGetPost = newCache $ \path -> do
   fileContent  <- readFile' path
   let toc = tocRequested (toS fileContent)
-  eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg def (toS fileContent)
+  eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg (def { readerStandalone = True }) (toS fileContent)
   case eitherResult of
     Left  _      -> fail "BAD"
     Right pandoc -> getBlogpostFromMetas path toc pandoc

src/css/y.css

@@ -556,9 +556,10 @@ a,a:visited { color: var(--hl); }
 
 /* ---- SYNTAX HIGHLIGHTING ---- */
 #table-of-contents { text-align: left; }
+
 .org-rainbow-delimiters-depth-1, .org-rainbow-delimiters-depth-9,
 .org-css-selector, .org-builtin,
-.IN_REVIEW {
+.IN_REVIEW, .ex {
     color:var(--c);
 }
 
@@ -573,7 +574,7 @@ a,a:visited { color: var(--hl); }
 }
 
 .org-rainbow-delimiters-depth-4, .org-diff-hunk-header, .org-sh-quoted-exec,
-.CANCELED {
+.CANCELED, .bu {
     color:var(--m);
 }
 .org-rainbow-delimiters-depth-5, .org-diff-removed, .TODO {

src/posts/0002-troll-2/index.org

@@ -44,9 +44,9 @@ goblins.
 Those costume looks very bad and cheap.
 So much you can only find them not terrorizing but funny and ridiculous.
 
+#+ATTR_HTML: A goblin
 #+CAPTION: One goblin during the introduction scene of Troll 2
 #+NAME: fig:troll-2-intro
-#+ATTR_HTML: A goblin
 [[./Troll-2-intro.jpg]]
 
 Soon after that, you realize the acting of all actors is extremely bad.
@@ -55,9 +55,9 @@ To give you an idea, the only equal bad acting I ever witnessed was while
 looking at amateurs first Youtube movies trying to follow a scenario.
 Apparently most actors were amateurs, it was their first and last movie.
 
+#+ATTR_HTML: A bad acting demonstration
 #+CAPTION: One particularly terrible acting scene
 #+NAME: fig:bad-acting
-#+ATTR_HTML: A bad acting demonstration
 [[file:bad-acting.png]]
 
 The dialog are, really something...
@@ -83,9 +83,9 @@ They win against the monsters with, what I believe was a failed attempt at
 humor.
 It misses the point so bad, that the irony still make it funny.
 
+#+ATTR_HTML: Eliott prevents his family to eat the food by urinating on the table
 #+CAPTION: Our hero save the day by urinating on the table. His family is frozen for 30s said grandpa, they were for 70s.
 #+NAME: fig:prevent-eating
-#+ATTR_HTML: Eliott prevents his family to eat the food by urinating on the table
 [[./prevent-eating-scene.jpg]]
 
 Of course, the very last scene is a classical so terrible cliché.

src/posts/0010-Haskell-Now/index.org

@@ -1492,7 +1492,7 @@ The only way to work around this problem is to use some meta-programming
 trick, for example using the pre-processor.
 In C++ there is a better way, C++ templates:
 
-#+BEGIN_SRC c++
+#+BEGIN_SRC cpp
 #include <iostream>
 #include <complex>
 using namespace std;
@@ -3880,9 +3880,7 @@ I will not argue much, but mainly, semantic versionning and Haskell
 versionning are just a "right to break things to your users".
 
 I don't want to talk a lot more about this, but, it would be nice if more
-people would watch this talk[fn:9] related to versionning.
+people would watch this talk[fn:8] related to versionning.
-
-[fn:9]: [[https://www.youtube.com/watch?v=oyLBGkS5ICk][Spec-ulation Keynote - Rich Hickey]]
 
 If you want to know more about Haskell versionning convention:
 https://pvp.haskell.org
@@ -4082,30 +4080,32 @@ Thank you man.
        As of today, the definition of =IO= is no more visible into =base=.
        We have the following explanation in [[http://hackage.haskell.org/package/base-4.12.0.0/docs/src/GHC.IO.html][=GHC.IO.hs=]]:
        #+begin_quote
-#+begin_src
+       #+begin_src
-The IO Monad is just an instance of the ST monad, where the state is
+       The IO Monad is just an instance of the ST monad, where the state is
-the real world.  We use the exception mechanism (in GHC.Exception) to
+       the real world.  We use the exception mechanism (in GHC.Exception) to
-implement IO exceptions.
+       implement IO exceptions.
-
+       
-NOTE: The IO representation is deeply wired in to various parts of the
+       NOTE: The IO representation is deeply wired in to various parts of the
-system.  The following list may or may not be exhaustive:
+       system.  The following list may or may not be exhaustive:
-
+       
-Compiler  - types of various primitives in PrimOp.hs
+       Compiler  - types of various primitives in PrimOp.hs
-
+       
-RTS       - forceIO (StgStartup.cmm)
+       RTS       - forceIO (StgStartup.cmm)
-          - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
+                 - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
-            (Exception.cmm)
+                   (Exception.cmm)
-          - raiseAsync (RaiseAsync.c)
+                 - raiseAsync (RaiseAsync.c)
-
+       
-Prelude   - GHC.IO.hs, and several other places including
+       Prelude   - GHC.IO.hs, and several other places including
-            GHC.Exception.hs.
+                   GHC.Exception.hs.
-
+       
-Libraries - parts of hslibs/lang.
+       Libraries - parts of hslibs/lang.
-
+       
---SDM
+       --SDM
-#+end_src
+       #+end_src
        #+end_quote
 
 [fn:7] Well, you'll certainly need to practice a bit to get used to them
        and to understand when you can use them and create your own. But
        you already made a big step in this direction.
+
+[fn:8] [[https://www.youtube.com/watch?v=oyLBGkS5ICk][Spec-ulation Keynote - Rich Hickey]]