update site source

cabal.project

@@ -0,0 +1,6 @@
+packages: ../achille .
+
+package achille
+  flags: +pandoc
+
+allow-newer: feed:base

content/assets/theme.css

@@ -31,10 +31,10 @@
 
 
 body {
-  font: 16px "Inter UI", sans-serif;
+  font: 16px "Inter UI", Inter, sans-serif;
   line-height: 1.54;
   margin: 0;
-  height: 100vh;
+  min-height: 100vh;
   color: var(--text);
   background: var(--background);
   display: flex;
@@ -184,6 +184,14 @@ main {
 p > span.display {
   display: block;
   overflow-x: auto;
+  overflow-y: clip;
+  margin: 2em 0;
+}
+
+p > span.display .katex { display:block } /* katex is shit */
+
+p > span.display math {
+  font-size: 1.2rem;
 }
 
 
@@ -195,8 +203,8 @@ main header h1 {margin: 0}
 main header p {margin: 0}
 main header {margin: 0 0 2em}
 
-main ul li { padding: 0 0 0 0 }
+main ul li, main ol li { padding: 0 0 0 0 }
-main ul { padding: 0 0 0 1.5em }
+main ul, main ol { padding: 0 0 0 1.5em }
 
 main ul.projects a { text-decoration: none; box-shadow: none }
 
@@ -226,16 +234,28 @@ main ul.projects li a p {
   margin: 0;
 }
 
-main ul.projects > li img {
+main ul.projects > li svg {
   width: 40px;
   margin: .5em 1em 0 0;
 }
 
+main ul.projects > li svg rect,
+main ul.projects > li svg path,
+main ul.projects > li svg use,
+header.project div svg rect,
+header.project div svg path,
+header.project div svg use {
+  fill: none;
+  stroke: var(--text);
+  stroke-linejoin: bevel;
+  stroke-linecap: round;
+}
+
 main ul.projects > li h2  { margin: 0; font-size: 1em }
 
 
 header.project { display: flex }
-header.project img {
+header.project svg {
   width: 40px;
   margin: 1em 2em 0 0;
 }
@@ -290,7 +310,7 @@ pre, div.sourceCode {
   overflow: auto;
 }
 
-div.sourceCode {
+pre, div.sourceCode {
   background: var(--dark);
 }
 
@@ -313,6 +333,28 @@ pre > code {
 figure {
   margin: 2em 0;
   text-align: center;
+  counter-increment: figure;
+}
+figure figcaption {
+  margin-top: 1em;
+}
+
+figure figcaption::before {
+  content: "Fig " counter(figure) ".";
+  padding-right: .5em;
+  font-style: italic;
+  font-weight: 400;
+}
+
+figure table {
+  margin: 0 auto;
+  border-collapse: collapse;
+}
+
+figure table th { font-weight: 500 }
+figure table th, figure table td {
+  border: 2px solid var(--darker);
+  padding: .3em .5em;
 }
 
 ol.pages {
@@ -466,8 +508,40 @@ table.books tr td:last-child  {text-align: center;color: var(--yellow)}
   cursor: default;
 }
 
+main { counter-reset: figure; }
 main > header h1   {line-height: 1.3  }
 main > header time {
   opacity: 0.6;
 }
 
+canvas { width: 100% }
+canvas.r1 { aspect-ratio:  1 }
+canvas.r2 { aspect-ratio:  2 }
+canvas.hw { width: 50%       }
+
+input[type=range] {
+  width: calc(100% - 2em);
+  margin: 1em 1em;
+  box-sizing: border-box;
+  display: block;
+}
+
+.grabber { cursor: grab }
+
+/* MathML styling */
+mover.seq > mrow:nth-child(2) { /* display: block */ }
+mover.seq > mrow:nth-child(1) {
+  border-top: .05em solid;
+}
+mover.seq > mrow:nth-child(2) {
+  padding-bottom: .1em;
+  border-bottom: .05em solid;
+  /* display: flex;
+  flex-direction: row;
+  gap: 1em;
+  justify-content: space-between; */
+}
+mover.seq > mrow { math-depth: 0 }
+mover.seq > mrow:nth-child(2) > * {
+  align-self: end;
+}

release.nix

@@ -1,11 +0,0 @@
-let
-  overlay = _: pkgs: {
-    haskellPackages = pkgs.haskellPackages.override {
-      overrides = self: super: rec {
-        achille = self.callPackage ../achille/achille.nix {};
-      };
-    };
-  };
-  pkgs = import <nixpkgs> { overlays = [ overlay ]; };
-
-in pkgs.haskellPackages.callPackage ./site.nix {}

site.cabal

@@ -18,6 +18,7 @@ executable site
                      , Templates
                      , Readings
                      , Route
+                     , Math
   build-depends:       base
                      , filepath
                      , achille
@@ -32,12 +33,14 @@ executable site
                      , binary
                      , containers
                      , sort
-                     , feed
+                     , feed >= 1.3.2.1
                      , time
                      , lucid
                      , optparse-applicative
                      , process
                      , directory
+                     , these
+                     , megaparsec
   default-extensions:   BlockArguments
                       , TupleSections
                       , OverloadedStrings

site.nix

@@ -1,19 +0,0 @@
-{ mkDerivation, achille, aeson, base, binary, bytestring
-, containers, data-default, directory, feed, filepath, lucid
-, optparse-applicative, pandoc, pandoc-types, process, sort, stdenv
-, text, time, yaml
-}:
-mkDerivation {
-  pname = "site";
-  version = "0.1.0.0";
-  src = ./.;
-  isLibrary = false;
-  isExecutable = true;
-  executableHaskellDepends = [
-    achille aeson base binary bytestring containers data-default
-    directory feed filepath lucid optparse-applicative pandoc
-    pandoc-types process sort text time yaml
-  ];
-  license = "unknown";
-  hydraPlatforms = stdenv.lib.platforms.none;
-}

src/Main.hs

@@ -51,7 +51,7 @@ build :: ShowDrafts -> Task IO ()
 build showDrafts = do
     -- static assets
     match_ "assets/*" copyFile
-    match_ "static/*" copyFile
+    match_ "static/**/*" copyFile
 
     -- quid page
     match_ "./quid.rst" \src ->
@@ -64,4 +64,3 @@ build showDrafts = do
     Projects.build
     Posts.build showDrafts lastImages
     -- Readings.build
-    return ()

src/Math.hs

@@ -0,0 +1,251 @@
+{-# LANGUAGE LambdaCase #-}
+-- | Little module to parse (a subset of) ASCIIMath
+module Math where
+
+import Data.Text (Text, pack, singleton)
+import Data.Text.Lazy (toStrict)
+import Data.These
+import Data.Char (isAlphaNum)
+import Data.Functor ((<&>))
+import Data.Void (Void)
+import Control.Monad (replicateM)
+import Text.Pandoc.Definition(Inline(..), Pandoc, Format(..), MathType(..))
+import Text.Pandoc.Walk (walk, walkM)
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+
+import Lucid.Base
+import Lucid.Html5
+
+
+-- Rendering
+
+-- Some MathML core elements
+
+-- | Element used to enclose math block.
+math_ :: Term a r => a -> r
+math_ = term "math"
+
+-- | Element used to render arbitrary text.
+mtext_ :: Functor m => HtmlT m a -> HtmlT m a
+mtext_ = makeElement "mtext"
+
+-- | Element used to represent a symbolic name or arbitrary text that should be rendered as an identifier.
+mi_ :: Functor m => HtmlT m a -> HtmlT m a
+mi_ = makeElement "mi"
+
+-- | Element used to represent a numeric literal.
+mn_ :: Functor m => HtmlT m a -> HtmlT m a
+mn_ = makeElement "mn"
+
+-- | Element used to represent an operator.
+mo_ :: Functor m => HtmlT m a -> HtmlT m a
+mo_ = makeElement "mo"
+
+-- | Element used to represent a blank space.
+mspace_ :: Applicative m => HtmlT m ()
+mspace_ = makeElementNoEnd "mspace"
+
+-- | Element used to represent a string literal.
+ms_ :: Functor m => HtmlT m a -> HtmlT m a
+ms_ = makeElement "ms"
+
+mtable_ :: Functor m => HtmlT m a -> HtmlT m a
+mtable_ = makeElement "mtable"
+
+mtr_ :: Functor m => HtmlT m a -> HtmlT m a
+mtr_ = makeElement "mtr"
+
+mtd_ :: Functor m => HtmlT m a -> HtmlT m a
+mtd_ = makeElement "mtd"
+
+-- | Element used to group together any number of sub-expressions.
+mrow_ :: Functor m => HtmlT m a -> HtmlT m a
+mrow_ = makeElement "mrow"
+
+-- | Element used for fractions. Can also be used to mark fraction-like objects.
+mfrac_ :: Term a r => a -> r
+mfrac_ = term "mfrac"
+
+-- | Element used to construct an expression with a root symbol.
+msqrt_ :: Functor m => HtmlT m a -> HtmlT m a
+msqrt_ = makeElement "msqrt"
+
+-- | Element used to construct an expression with a root and an index.
+--   It has exactly two children: it is a root of index the second child, applied to the first child.
+mroot_ :: Functor m => HtmlT m a -> HtmlT m a
+mroot_ = makeElement "mroot"
+
+mpadded_ :: Functor m => HtmlT m a -> HtmlT m a
+mpadded_ = makeElement "mpadded"
+
+merror_ :: Functor m => HtmlT m a -> HtmlT m a
+merror_ = makeElement "merror"
+
+msup_ :: Functor m => HtmlT m a -> HtmlT m a
+msup_ = makeElement "msup"
+
+msub_ :: Functor m => HtmlT m a -> HtmlT m a
+msub_ = makeElement "msub"
+
+msubsup_ :: Functor m => HtmlT m a -> HtmlT m a
+msubsup_ = makeElement "msub"
+
+munderover_ :: Term a r => a -> r
+munderover_ = term "munderover"
+
+munder_ :: Term a r => a -> r
+munder_ = term "munder"
+
+mover_ :: Term a r => a -> r
+mover_ = term "mover"
+
+-- | Either @infix@, @prefix@ or @postfix@, property of an embellished operator.
+form_ :: Text -> Attribute
+form_ = makeAttribute "form"
+
+lspace_ :: Text -> Attribute
+lspace_ = makeAttribute "lspace"
+
+rspace_ :: Text -> Attribute
+rspace_ = makeAttribute "rspace"
+
+display_ :: Text -> Attribute
+display_ = makeAttribute "display"
+
+------------
+
+-- | AST for math expression, made to be close to MathML.
+data Exp
+  = MError Text
+  | MText Text
+  | MFrac [Attribute] Exp Exp
+  | MIdent Text
+  | MMultiScript
+  | MRow [Exp]
+  | MNum Text
+  | MOp Text -- TODO (operator attributes)
+  | MUnderOver [Attribute] (These Exp Exp) Exp
+  | MSubSup (These Exp Exp) Exp
+  | MRoot (Maybe Exp) Exp
+  | MTable [[Exp]]
+  | Empty
+  deriving (Show, Eq)
+
+testExp :: Exp
+testExp = MRoot Nothing (MRow [MIdent "x", MOp "+", MNum "1"])
+
+instance ToHtml Exp where
+
+  toHtml (MError e) = merror_ (toHtml e)
+  toHtml (MText t) = mtext_ (toHtml t)
+  toHtml (MIdent i) = mi_ (toHtml i)
+  toHtml (MFrac attrs a b) = mfrac_ attrs (toHtml a <> toHtml b)
+  toHtml (MNum t) = mn_ (toHtml t)
+  toHtml (MRow r) = mrow_ (foldMap toHtml r)
+  toHtml (MOp t) = mo_ (toHtml t)
+  toHtml Empty = mempty
+  toHtml (MUnderOver attrs (This a)    t) = munder_ attrs (toHtml t <> toHtml a)
+  toHtml (MUnderOver attrs (That b)    t) = mover_ attrs (toHtml t             <> toHtml b)
+  toHtml (MUnderOver attrs (These a b) t) = munderover_ attrs (toHtml t <> toHtml a <> toHtml b)
+  toHtml (MRoot Nothing t)  = msqrt_ (toHtml t)
+  toHtml (MRoot (Just r) t) = mroot_ (toHtml t <> toHtml r)
+  toHtml (MTable rows) = mtable_ $ foldMap (mtr_ . foldMap (mtd_ . toHtml)) rows
+  toHtml _ = mempty
+
+  toHtmlRaw = toHtml -- TODO: provide unescaped HTML
+
+
+type Parser = Parsec Void Text
+
+sc :: Parser ()
+sc = L.space space1 empty empty
+
+lexeme :: Parser a -> Parser a
+lexeme = L.lexeme sc
+
+symbol :: Text -> Parser Text
+symbol = L.symbol sc
+
+brackets :: [(Text, Text)]
+brackets = [ ("(", ")")
+           , ("[", "]")
+           , ("⟦", "⟧")
+           , ("⦃", "⦄")
+           , ("⟨", "⟩")
+           ]
+
+bracketedP :: Parser Exp
+bracketedP = do
+  (l, r) <- choice [ pure b <* string (fst b) | b <- brackets ]
+  es <- sc *> rowP <* string r <* sc
+  pure $ MRow ([MOp l] ++ es ++ [MOp r])
+
+matP :: Parser Exp
+matP = do
+  "mat" <* sc
+  (n, m) <-
+    (,) <$ "(" <* sc
+        <*> L.decimal <* sc <* "," <* sc
+        <*> L.decimal <* sc <* ")" <* sc
+  els <- replicateM n (replicateM m atomP)
+  pure (MTable els)
+
+-- atomic elements
+atomP :: Parser Exp
+atomP = bracketedP
+    <|> ("{" *> sc *> expP <* "}" <* sc)
+    <|> matP
+    <|> try (MNum . pack . show <$> lexeme L.decimal)   -- integer (TODO: number literal)
+    <|> try (MIdent <$> takeWhile1P Nothing isAlphaNum <* sc) -- identifier
+    <|> try do
+          c <- anySingle <* sc
+          if c == '√' then do
+            e <- atomP
+            return (MRoot Nothing e)
+          else if c `elem` ['+', '-', '∶', '⊢', '→'] then return (MOp (singleton c))
+          else empty
+
+fracP :: Parser Exp
+fracP = do
+  l <- atomP
+  try (MFrac [] l <$> ("/" *> sc *> atomP)) <|> pure l
+
+-- | parse a sequence of atomP elements
+rowP :: Parser [Exp]
+rowP = sc *> many fracP
+
+seqP :: Parser Exp
+seqP = do
+  l <- rowP
+  (do
+    try $ some "─" <* sc
+    r <- rowP
+    pure (MUnderOver [class_ "seq"] (That (MRow l)) (MRow r))
+    ) <|> pure (MRow l)
+
+-- | Top-level exp parser
+expP :: Parser Exp
+expP = seqP -- <&> \case
+  -- [ ] -> Empty
+  -- [e] -> e
+  -- xs  -> (MRow xs)
+
+toExp :: Text -> Either String Exp
+toExp src = 
+  case runParser expP "math block" src of
+    Left err -> Left (errorBundlePretty err)
+    Right e  -> Right e
+
+processInline :: MonadFail m => Inline -> m Inline
+processInline (Math t e) =
+  case toExp e of
+    Left err -> fail err
+    Right e  -> pure $
+      RawInline (Format "html") $ toStrict $ renderText $
+        math_ [ display_ (if t == DisplayMath then "block" else "inline") ] $ toHtml e
+processInline i = pure i
+
+processMath :: MonadFail m => Pandoc -> m Pandoc
+processMath = walkM processInline

src/Posts.hs

@@ -7,6 +7,7 @@ import Data.Time.Clock  (getCurrentTime)
 import Data.Time.Format (rfc822DateFormat, formatTime)
 import Data.List        (isPrefixOf)
 import Data.Foldable    (for_)
+import Data.Text        (unpack)
 import GHC.Generics
 import Lucid hiding (for_)
 
@@ -27,10 +28,12 @@ import System.Directory ( setCurrentDirectory
                         , renameDirectory
                         , createDirectoryIfMissing
                         )
+import Math
 
 --  metadata used for parsing YAML headers
 data PostMeta = PostMeta
     { title       :: Text
+    , date        :: Text
     , draft       :: Maybe Bool
     , description :: Maybe Text
     } deriving (Generic, Eq, Show, FromJSON)
@@ -53,12 +56,13 @@ buildPost src = do
     let ext = takeExtensions src
     if ".lagda.md" `isPrefixOf` ext then processAgda src
     else do
-        (PostMeta title draft desc, pandoc) <- readPandocMetadataWith ropts src
+        (PostMeta title date draft desc, pandoc) <- readPandocMetadataWith ropts src
-        content <- renderPandocWith wopts pandoc
+        pandoc' <- processMath pandoc
-        let date = timestamp src
+        content <- renderPandocWith wopts pandoc'
-        pure (renderPost date title content)
+        let time = timestamp (unpack date)
+        pure (renderPost time title content)
             >>= write (src -<.> "html")
-            <&> Post title date (fromMaybe False draft) Nothing content
+            <&> Post title time (fromMaybe False draft) Nothing content
 
     where
         processAgda :: FilePath -> Task IO Post
@@ -83,13 +87,13 @@ buildPost src = do
 
             let tpath = odir </> "index.md"
 
-            (PostMeta title draft desc, pandoc) <- readAbsPandocMetadataWith ropts tpath
+            (PostMeta title date draft desc, pandoc) <- readAbsPandocMetadataWith ropts tpath
             content <- renderPandocWith wopts pandoc
-            let date = timestamp src
+            let time = timestamp (unpack date)
-            pure (renderPost date title content)
+            pure (renderPost time title content)
                 >>= write (dropExtensions src </> "index.html")
                 <&> takeDirectory
-                <&> Post title date (fromMaybe False draft) Nothing content
+                <&> Post title time (fromMaybe False draft) Nothing content
 
 
 build :: Bool -> [Image] -> Task IO ()

src/Projects.hs

@@ -28,21 +28,23 @@ build = do
         write "projects.html" (renderIndex intro projects)
 
 
-buildProject :: FilePath -> Task IO (Project, FilePath)
+buildProject :: FilePath -> Task IO (Project, Text, FilePath)
 buildProject src = do
     match "*" copyFile
 
     name     <- takeBaseName <$> getCurrentDir
     children <- buildChildren name
 
-    watch children $ matchFile "index.*" \src -> do
+    icon     <- matchFile "logo.svg" readText
+
+    watch children $ watch icon $ matchFile "index.*" \src -> do
         (meta, doc) <- readPandocMetadataWith ropts src
 
         renderPandocWith wopts doc
-            <&> renderProject meta children
+            <&> renderProject meta icon children
             >>= write (src -<.> "html")
 
-        (meta,) <$> getCurrentDir
+        (meta, icon,) <$> getCurrentDir
     where
         buildChildren :: String -> Task IO [(Text, FilePath)]
         buildChildren name = match "pages/*" \filepath -> do
@@ -57,14 +59,14 @@ buildProject src = do
                 <&> (title,)
 
 
-renderProject :: Project -> [(Text, FilePath)] -> Text -> Html ()
+renderProject :: Project -> Text -> [(Text, FilePath)] -> Text -> Html ()
-renderProject Project{..} children content =
+renderProject Project{..} logo children content =
     outerWith def { Config.title       = title
                   , Config.description = subtitle
                   , Config.route       = ProjectRoute title
                   } do
         header_ [class_ "project"] do
-            div_ (img_ [src_ "logo.svg"])
+            div_ (toHtmlRaw logo)
             div_ do
                 h1_ (toHtml title)
                 p_  (toHtml subtitle)
@@ -80,7 +82,7 @@ renderProject Project{..} children content =
         toHtmlRaw content
 
 
-renderIndex :: Text -> [(Project, FilePath)] -> Html ()
+renderIndex :: Text -> [(Project, Text, FilePath)] -> Html ()
 renderIndex intro projects =
     outerWith def { Config.title = "projects"
                   , Config.description = intro
@@ -88,10 +90,10 @@ renderIndex intro projects =
         toHtmlRaw intro
         ul_ [class_ "projects"] $ forM_ projects projectLink
     where
-        projectLink :: (Project, FilePath) -> Html ()
+        projectLink :: (Project, Text, FilePath) -> Html ()
-        projectLink (Project{..}, path) =
+        projectLink (Project{..}, logo, path) =
             li_ $ a_ [href_ (fromString path)] do
-                div_ $ img_ [src_ (fromString $ path </> "logo.svg")]
+                div_ $ toHtmlRaw logo
                 div_ $ h2_ (toHtml title) >> p_  (toHtml subtitle)
 
 

src/Templates.hs

@@ -83,10 +83,12 @@ outerWith SiteConfig{title,route,..} content = doctypehtml_ do
         main_ content
 
         footer_ [ id_ "ft" ] do
-            "flupe 2020 · "
+            "flupe 2022 · "
             a_ [ href_ "https://creativecommons.org/licenses/by-nc/2.0/" ]
                 "CC BY-NC 2.0"
             " · "
             a_ [ href_ "https://instagram.com/ba.bou.m/", rel_ "me" ] "instagram"
             " · "
+            a_ [ href_ "https://mastodon.social/@baboum", rel_ "me" ] "mastodon"
+            " · "
             a_ [ href_ "/atom.xml" ] "feed"

src/Visual.hs

@@ -5,7 +5,7 @@ import Data.List (isSuffixOf)
 import qualified Config
 import Common
 import Templates (outerWith, loading_)
-import Lucid
+import Lucid hiding (loading_)
 import Route
 
 

upload.sh

@@ -0,0 +1,2 @@
+#!/bin/sh
+rsync -e 'ssh -p 222' -avz _site/ lucas@sbi.re:/var/lib/www/acatalepsie.fr