Started writing the main utilities for my webpage

8 files changed, 333 insertions, 0 deletions

diff --git a/src/Hakyll/Core/Identifier/Pattorn.hs b/src/Hakyll/Core/Identifier/Pattorn.hs
new file mode 100644
index 0000000..0910320
--- /dev/null
+++ b/src/Hakyll/Core/Identifier/Pattorn.hs
@@ -0,0 +1,16 @@
+module Hakyll.Core.Identifier.Pattorn
+    ( Pattorn (..)
+    ) where
+
+import Prolog
+import Hakyll
+
+-- | Wrapper around 'Pattern' to get a semigroup with "or" as its operation
+newtype Pattorn = Pattorn { getPattern :: Pattern }
+    deriving newtype (Binary, Show, IsString)
+
+instance Semigroup Pattorn where
+    Pattorn a <> Pattorn b = Pattorn $ a .||. b
+
+instance Monoid Pattorn where
+    mempty = Pattorn $ complement mempty
diff --git a/src/Hakyll/TeX/BibTeX.hs b/src/Hakyll/TeX/BibTeX.hs
new file mode 100644
index 0000000..b085dfa
--- /dev/null
+++ b/src/Hakyll/TeX/BibTeX.hs
@@ -0,0 +1,36 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hakyll.TeX.BibTeX
+    ( bibtexCompiler
+    , compileBibtex
+    , BibTeX
+    ) where
+
+import Prolog
+
+import Data.List qualified as L
+import Hakyll
+import Text.BibTeX.Entry qualified as B
+import Text.BibTeX.Format qualified as B
+import Text.BibTeX.Parse qualified as B
+import Text.Parsec qualified as P
+import Text.Parsec.Error qualified as P
+
+type BibTeX = B.T
+
+deriving instance Generic B.T
+instance Binary B.T
+
+instance Writable B.T where
+    write p = write p . B.entry
+
+instance Writable [B.T] where
+    write p = write p . fold . L.intersperse "\n" . fmap B.entry
+
+
+compileBibtex :: (StringConv s String) => Item s -> Compiler (Item [B.T])
+compileBibtex (Item i b) = either (throwError . fmap P.messageString . P.errorMessages) (pure . Item i) $ P.parse p (show i) (toSL b)
+    where
+        p = B.skippingLeadingSpace $ B.file <* P.eof
+
+bibtexCompiler :: Compiler (Item [B.T])
+bibtexCompiler = getResourceBody >>= compileBibtex
diff --git a/src/Hakyll/TeX/HaTeX.hs b/src/Hakyll/TeX/HaTeX.hs
new file mode 100644
index 0000000..9b83c62
--- /dev/null
+++ b/src/Hakyll/TeX/HaTeX.hs
@@ -0,0 +1,15 @@
+module Hakyll.TeX.HaTeX
+    ( hatexCompiler
+    , compileHatex
+    ) where
+
+import Prolog
+
+import Hakyll
+import Text.LaTeX.Base.Parser
+
+compileHatex :: (StringConv s Text, Traversable t) => t s -> Compiler (t LaTeX)
+compileHatex = traverse $ either (throwError . fmap messageString . errorMessages) pure . parseLaTeX . toSL
+
+hatexCompiler :: Compiler (Item LaTeX)
+hatexCompiler = getResourceLBS >>= compileHatex
diff --git a/src/Hakyll/TeX/LaTeX.hs b/src/Hakyll/TeX/LaTeX.hs
new file mode 100644
index 0000000..8f6d5cc
--- /dev/null
+++ b/src/Hakyll/TeX/LaTeX.hs
@@ -0,0 +1,18 @@
+module Hakyll.TeX.LaTeX
+    ( latexPdfCompiler
+    , compileLatexPdf
+    , rubberPipe
+    ) where
+
+import Prolog
+
+import Hakyll
+
+rubberPipe :: [String] -> LazyByteString -> Compiler LazyByteString
+rubberPipe = unixFilterLBS "rubber-pipe"
+
+compileLatexPdf :: (StringConv s LazyByteString, Traversable t) => t s -> Compiler (t LazyByteString)
+compileLatexPdf = traverse $ rubberPipe [ "--pdf" ] . toSL
+
+latexPdfCompiler :: Compiler (Item LazyByteString)
+latexPdfCompiler = getResourceLBS >>= compileLatexPdf
diff --git a/src/Hakyll/TeX/TikZ.hs b/src/Hakyll/TeX/TikZ.hs
new file mode 100644
index 0000000..9df98fd
--- /dev/null
+++ b/src/Hakyll/TeX/TikZ.hs
@@ -0,0 +1,29 @@
+module Hakyll.TeX.TikZ
+    ( TikzTemplate
+    , tikzfilter
+    , tikzBlockFilter
+    ) where
+
+import Network.URI.Encode qualified as URI
+import Text.Pandoc.Definition
+import Text.Pandoc.Walk (walkM)
+
+import Hakyll
+
+import Prolog
+
+import Hakyll.TeX.LaTeX (rubberPipe)
+
+type TikzTemplate = Identifier
+
+tikzFilter :: TikzTemplate -> Pandoc -> Compiler Pandoc
+tikzFilter = walkM tikzBlockFilter
+
+-- | Requires `rubber` and `poppler_utils`
+tikzBlockFilter :: TikzTemplate -> Block -> Compiler Block
+tikzBlockFilter tmpl (CodeBlock info@(_, "tikzpicture":_, _) contents) = do
+    let imageBlock fname = Para [ Image info [] (toSL fname, "") ]
+    makeItem (toSL contents) >>= loadAndApplyTemplate tmpl (bodyField "body") >>=
+        traverse (convSL $ rubberPipe [ "--pdf" ] >=> unixFilterLBS "pdftocairo" [ "-svg", "-", "-" ]) >>=
+            \(Item _ b) -> imageBlock $ ("data:image/svg+sml;utf8," <>) $ URI.encode $ filter (/= '\n') b
+tikzBlockFilter _ x = pure x
diff --git a/src/Prolog.hs b/src/Prolog.hs
new file mode 100644
index 0000000..70545c9
--- /dev/null
+++ b/src/Prolog.hs
@@ -0,0 +1,166 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Prolog
+    (
+    -- * Modules
+      module Control.Applicative
+    , module Control.Monad
+    , module Control.Monad.Except
+    , module Control.Monad.Identity
+    , module Control.Monad.IO.Class
+    , module Control.Monad.Reader
+    , module Data.Bifunctor
+    , module Data.Bifoldable
+    , module Data.Bitraversable
+    , module Data.Bool
+    , module Data.Either
+    , module Data.Foldable
+    , module Data.Function
+    , module Data.Functor
+    , module Data.Functor.Contravariant
+    , module Data.Maybe
+    -- * Types
+    , Binary
+    , Generic
+    , Generically (..)
+    , MonadThrow (..)
+    , Exception (..)
+    , SomeException (..)
+    , B.StrictByteString
+    , BL.LazyByteString
+    , T.StrictText
+    , TL.LazyText
+    -- * Strings
+    , IsString (..)
+    , StringConv (..)
+    , toS
+    , toSL
+    , convS
+    , convSL
+    -- * Utils
+    , (<<$>>)
+    , (<<<$>>>)
+    , (<<&>>)
+    , (-->)
+    , (-/>)
+    , foreach
+    , liftMaybe
+    , squashMaybe
+    ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.Except
+import Control.Monad.Identity
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Data.Bifunctor
+import Data.Bifoldable
+import Data.Binary
+import Data.Bitraversable
+import Data.Bool
+import Data.ByteString qualified as B
+import Data.ByteString.Lazy qualified as BL
+import Data.Either
+import Data.Foldable
+import Data.Function
+import Data.Functor
+import Data.Functor.Contravariant
+import Data.Maybe
+import Data.String
+import Data.String.Conv
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as TL
+import GHC.Generics
+
+import Hakyll qualified as H
+import Text.Blaze.Html
+import Text.Blaze.Html.Renderer.Pretty as BS
+import Text.Blaze.Html.Renderer.Text as BT
+import Text.Blaze.Html.Renderer.Utf8 as BB
+import Text.LaTeX.Base qualified as L
+
+(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
+infixl 4 <<$>>
+(<<$>>) = fmap fmap fmap
+{-# INLINE (<<$>>) #-}
+
+(<<<$>>>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))
+infixl 4 <<<$>>>
+(<<<$>>>) = fmap . fmap . fmap
+{-# INLINE (<<<$>>>) #-}
+
+(<<&>>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b)
+infixl 1 <<&>>
+(<<&>>) = flip (<<$>>)
+{-# INLINE (<<&>>) #-}
+
+foreach :: Functor f => f a -> (a -> b) -> f b
+foreach = flip fmap
+{-# INLINE foreach #-}
+
+
+(-->) :: (Monad m, Monoid w) => m Bool -> m w -> m w
+infixr 0 -->
+b --> a = b >>= bool (pure mempty) a
+{-# INLINE (-->) #-}
+
+(-/>) :: (Monad m, Monoid w) => m Bool -> m w -> m w
+infixr 0 -/>
+(-/>) = (-->) . fmap not
+{-# INLINE (-/>) #-}
+
+liftMaybe :: Alternative m => Maybe a -> m a
+liftMaybe = maybe empty pure
+{-# INLINE liftMaybe #-}
+
+squashMaybe :: Alternative m => m (Maybe a) -> m a
+squashmaybe = (>>= liftMaybe)
+{-# INLINE squashMaybe #-}
+
+
+-- Orphan instances
+
+
+instance Binary L.MathType
+instance Binary L.Measure
+instance Binary L.TeXArg
+instance Binary L.LaTeX
+
+instance H.Writable L.LaTeX where
+    write p = L.renderFile p . H.itemBody
+
+
+instance Contravariant H.Context where
+    contramap f (H.Context c) = H.Context $ \x xs -> c x xs . fmap f
+
+
+instance StringConv L.LaTeX T.Text where
+    strConv _ = L.render
+
+instance StringConv L.LaTeX TL.Text where
+    strConv l = strConv l . L.render
+
+instance StringConv L.LaTeX B.ByteString where
+    strConv l = strConv l . L.render
+
+instance StringConv L.LaTeX BL.ByteString where
+    strConv l = strConv l . L.render
+
+instance StringConv L.LaTeX String where
+    strConv l = strConv l . L.render
+
+instance StringConv Html T.Text where
+    strConv _ = BT.renderHtml
+
+instance StringConv Html TL.Text where
+    strConv l = strConv l . BT.renderHtml
+
+instance StringConv Html String where
+    strConv _ = BS.renderHtml
+
+instance StringConv Html B.ByteString where
+    strConv l = strConv l . BB.renderHtml
+
+instance StringConv Html BL.ByteString where
+    strConv _ = BB.renderHtml
diff --git a/src/WWW/Base.hs b/src/WWW/Base.hs
new file mode 100644
index 0000000..4f8d1c7
--- /dev/null
+++ b/src/WWW/Base.hs
@@ -0,0 +1,39 @@
+module WWW.Base
+    ( baseConfig
+    , baseHakyll
+    , domain
+    , wwwRoot
+    ) where
+
+import Prolog
+import Hakyll
+import System.Process
+
+
+hakyllVersion :: IsString s => s
+hakyllVersion = "Hakyll 4.16.2.2"
+
+-- | mathematicaster.org
+domain :: IsString s => s
+domain = "mathematicaster.org"
+
+-- | /var/www
+wwwRoot :: IsString s => s
+wwwRoot = "/var/www"
+
+baseConfig :: FilePath -> Configuration
+baseConfig p = defaultConfiguration
+    { destinationDirectory = "output"
+    , storeDirectory = ".cache"
+    , tmpDirectory = ".cache/tmp"
+    , deploySite = \cfg -> rawSystem "rsync"
+        [ "-aP"
+        , "--delete-after"
+        , "--chown=nginx:nginx"
+        , destinationDirectory cfg <> "/"
+        , "root@" <> domain <> ":" <> wwwRoot <> "/" <> p
+        ]
+    }
+
+baseHakyll :: MonadIO m => FilePath -> Rules a -> m ()
+baseHakyll p = liftIO . hakyllWith (baseConfig p)
diff --git a/src/WWW/HW.hs b/src/WWW/HW.hs
new file mode 100644
index 0000000..0740fe6
--- /dev/null
+++ b/src/WWW/HW.hs
@@ -0,0 +1,14 @@
+module WWW.HW
+    ( removeEnv
+    , removeSolutions
+    ) where
+
+import Prolog
+
+import Text.LaTeX.Base.Syntax
+
+removeEnv :: (String -> Bool) -> LaTeX -> LaTeX
+removeEnv p = texmap (\case { TeXEnv s _ _ -> p s; _ -> False }) $ pure mempty
+
+removeSolutions :: LaTeX -> LaTeX
+removeSolutions = removeEnv (== "solution")