This commit is contained in:
Yann Esposito (Yogsototh) 2020-06-23 09:15:03 +02:00
parent d201cf8b1b
commit 2bdc881cc9
Signed by untrusted user who does not match committer: yogsototh
GPG Key ID: 7B19A4C650D59646
3 changed files with 54 additions and 51 deletions

View File

@ -28,8 +28,9 @@ import Text.Pandoc.Definition ( Pandoc(..)
) )
import Text.Pandoc.Extensions ( getDefaultExtensions ) import Text.Pandoc.Extensions ( getDefaultExtensions )
import Text.Pandoc.Options ( ReaderOptions(..) import Text.Pandoc.Options ( ReaderOptions(..)
, TrackChanges(RejectChanges) , WriterOptions(..)
) , TrackChanges(RejectChanges)
)
import qualified Text.Pandoc.Readers as Readers import qualified Text.Pandoc.Readers as Readers
import qualified Text.Pandoc.Templates as PandocTemplates import qualified Text.Pandoc.Templates as PandocTemplates
import qualified Text.Pandoc.Writers as Writers import qualified Text.Pandoc.Writers as Writers
@ -59,8 +60,8 @@ data BlogPost =
, postDate :: T.Text , postDate :: T.Text
, postAuthors :: [T.Text] , postAuthors :: [T.Text]
, postUrl :: FilePath , postUrl :: FilePath
, postToc :: Bool
, postBody :: Pandoc , postBody :: Pandoc
-- , postToc :: Boolean
} }
inlineToText :: PandocMonad m => [Inline] -> m T.Text inlineToText :: PandocMonad m => [Inline] -> m T.Text
@ -68,13 +69,13 @@ inlineToText inline =
Writers.writeAsciiDoc def (Pandoc nullMeta [Plain inline]) Writers.writeAsciiDoc def (Pandoc nullMeta [Plain inline])
getBlogpostFromMetas getBlogpostFromMetas
:: (MonadIO m, MonadFail m) => [Char] -> Pandoc -> m BlogPost :: (MonadIO m, MonadFail m) => [Char] -> Bool -> Pandoc -> m BlogPost
getBlogpostFromMetas path pandoc@(Pandoc meta _) = do getBlogpostFromMetas path toc pandoc@(Pandoc meta _) = do
eitherBlogpost <- liftIO $ Pandoc.runIO $ do eitherBlogpost <- liftIO $ Pandoc.runIO $ do
title <- inlineToText $ docTitle meta title <- inlineToText $ docTitle meta
date <- inlineToText $ docDate meta date <- inlineToText $ docDate meta
authors <- mapM inlineToText $ docAuthors meta authors <- mapM inlineToText $ docAuthors meta
return $ BlogPost title date authors path pandoc return $ BlogPost title date authors path toc pandoc
case eitherBlogpost of case eitherBlogpost of
Left _ -> fail "BAD" Left _ -> fail "BAD"
Right bp -> return bp Right bp -> return bp
@ -104,7 +105,7 @@ buildRules = do
liftIO $ putText $ "need: " <> (toS srcFile) <> " <- " <> (toS out) liftIO $ putText $ "need: " <> (toS srcFile) <> " <- " <> (toS out)
need $ css <> [srcFile] need $ css <> [srcFile]
bp <- getPost srcFile bp <- getPost srcFile
eitherHtml <- liftIO $ Pandoc.runIO $ Writers.writeHtml5String def (postBody bp) eitherHtml <- liftIO $ Pandoc.runIO $ Writers.writeHtml5String (def { writerTableOfContents = (postToc bp) }) (postBody bp)
case eitherHtml of case eitherHtml of
Left _ -> fail "BAD" Left _ -> fail "BAD"
Right innerHtml -> Right innerHtml ->
@ -147,21 +148,23 @@ mkGetTemplate = newCache $ \path -> do
Left _ -> fail "BAD" Left _ -> fail "BAD"
Right template -> return template Right template -> return template
parseOptions :: Text -> [Text] -> Maybe Text tocRequested :: Text -> Bool
parseOptions fc = tocRequested fc =
fc & T.lines let toc = fc & T.lines
& map T.toLower & map T.toLower
& filter (T.isPrefixOf (T.pack "#options: ")) & filter (T.isPrefixOf (T.pack "#+options: "))
& head & head
& fmap (filter (T.isPrefixOf (T.pack "toc:")) . T.words)
in toc == Just ["toc:t"]
mkGetPost :: Rules (FilePath -> Action BlogPost) mkGetPost :: Rules (FilePath -> Action BlogPost)
mkGetPost = newCache $ \path -> do mkGetPost = newCache $ \path -> do
fileContent <- readFile' path fileContent <- readFile' path
let options = parseOptions (toS fileContent) let toc = tocRequested (toS fileContent)
eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg def (toS fileContent) eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg def (toS fileContent)
case eitherResult of case eitherResult of
Left _ -> fail "BAD" Left _ -> fail "BAD"
Right pandoc -> getBlogpostFromMetas path pandoc Right pandoc -> getBlogpostFromMetas path toc pandoc
mkGetPosts :: (FilePath -> Action b) -> Rules (() -> Action [b]) mkGetPosts :: (FilePath -> Action b) -> Rules (() -> Action [b])
mkGetPosts getPost = mkGetPosts getPost =

View File

@ -564,7 +564,7 @@ a,a:visited { color: var(--hl); }
.org-rainbow-delimiters-depth-2, .org-nix-builtin, .org-variable-name, .org-rainbow-delimiters-depth-2, .org-nix-builtin, .org-variable-name,
.org-haskell-definition, .org-haskell-operator, .org-function-name, .org-diff-changed, .org-haskell-definition, .org-haskell-operator, .org-function-name, .org-diff-changed,
.org-nix-attribute, .org-nxml-element-local-name { .org-nix-attribute, .org-nxml-element-local-name, .op, .fu, .ot {
color:var(--b); color:var(--b);
} }
@ -579,15 +579,15 @@ a,a:visited { color: var(--hl); }
.org-rainbow-delimiters-depth-5, .org-diff-removed, .TODO { .org-rainbow-delimiters-depth-5, .org-diff-removed, .TODO {
color:var(--r); color:var(--r);
} }
.org-rainbow-delimiters-depth-6, .org-haskell-constructor { .org-rainbow-delimiters-depth-6, .org-haskell-constructor, .dt {
color:var(--o); color:var(--o);
} }
.org-rainbow-delimiters-depth-7, .org-type, .org-constant, .org-diff-header, .org-rainbow-delimiters-depth-7, .org-type, .org-constant, .org-diff-header,
.org-haskell-keyword, .org-haskell-type, .IN_PROGRESS { .org-haskell-keyword, .org-haskell-type, .IN_PROGRESS, .kw {
color:var(--y); color:var(--y);
} }
.org-rainbow-delimiters-depth-8, .org-sh-heredoc, .org-diff-added, .org-string, .org-rainbow-delimiters-depth-8, .org-sh-heredoc, .org-diff-added, .org-string,
.org-doc, .org-keyword, .DONE { .org-doc, .org-keyword, .DONE, .st {
color:var(--g); color:var(--g);
} }
@ -595,6 +595,6 @@ a,a:visited { color: var(--hl); }
.org-diff-none, .org-preprocessor, .org-comment-delimiter, .org-comment, .org-diff-none, .org-preprocessor, .org-comment-delimiter, .org-comment,
.org-outshine-level-1, .org-outshine-level-2, .org-outshine-level-3, .org-outshine-level-1, .org-outshine-level-2, .org-outshine-level-3,
.org-outshine-level-4, .org-outshine-level-5, .org-outshine-level-6, .org-outshine-level-4, .org-outshine-level-5, .org-outshine-level-6,
.org-outshine-level-7, .org-outshine-level-8, .org-outshine-level-9 { .org-outshine-level-7, .org-outshine-level-8, .org-outshine-level-9, .co {
color:var(--fg0); color:var(--fg0);
} }

View File

@ -178,32 +178,32 @@ Otherwise, you can follow my advice to use nix:
4. Put the following =shell.nix= file inside it 4. Put the following =shell.nix= file inside it
#+begin_src nix :tangle shell.nix #+begin_src nix :tangle shell.nix
{ nixpkgs ? import (fetchTarball https://github.com/NixOS/nixpkgs/archive/19.09.tar.gz) {} }: { nixpkgs ? import (fetchTarball https://github.com/NixOS/nixpkgs/archive/19.09.tar.gz) {} }:
let let
inherit (nixpkgs) pkgs; inherit (nixpkgs) pkgs;
inherit (pkgs) haskellPackages; inherit (pkgs) haskellPackages;
haskellDeps = ps: with ps; [ haskellDeps = ps: with ps; [
base base
protolude protolude
containers containers
]; ];
ghc = haskellPackages.ghcWithPackages haskellDeps; ghc = haskellPackages.ghcWithPackages haskellDeps;
nixPackages = [ nixPackages = [
ghc ghc
pkgs.gdb pkgs.gdb
haskellPackages.cabal-install haskellPackages.cabal-install
]; ];
in in
pkgs.stdenv.mkDerivation { pkgs.stdenv.mkDerivation {
name = "env"; name = "env";
buildInputs = nixPackages; buildInputs = nixPackages;
shellHook = '' shellHook = ''
export PS1="\n\[[hs:\033[1;32m\]\W\[\033[0m\]]> " export PS1="\n\[[hs:\033[1;32m\]\W\[\033[0m\]]> "
''; '';
} }
#+end_src #+end_src
5. In the =hsenv= directory, in a terminal, run =nix-shell --pure=. 5. In the =hsenv= directory, in a terminal, run =nix-shell --pure=.
@ -219,11 +219,11 @@ pkgs.stdenv.mkDerivation {
something like this: something like this:
#+begin_src #+begin_src
~/hsenv> nix-shell ~/hsenv> nix-shell
[nix-shell:~/hsenv]$ ghci [nix-shell:~/hsenv]$ ghci
GHCi, version 8.6.5: http://www.haskell.org/ghc/ :? for help GHCi, version 8.6.5: http://www.haskell.org/ghc/ :? for help
Prelude> import Protolude Prelude> import Protolude
Prelude Protolude> Prelude Protolude>
#+end_src #+end_src
Congratulations you should be ready to start now. Congratulations you should be ready to start now.