Move SiteGenerator into executable only and rename library to Byg.*

byg/src/Byg/Functions/Atom.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE RebindableSyntax #-}
+module Byg.Functions.Atom
+  ( generateAtom
+  ) where
+
+import Prelude
+
+import Byg.Types (Token, Date(..), formatDateShort)
+import Byg.DependencyGenerator (DepGenM, TokenableTo(..), onTupleToken)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+fromString :: String -> Text
+fromString = T.pack
+
+class IsStructure a where
+  toStructure :: a -> Structure
+
+instance IsStructure Structure where
+  toStructure = id
+
+instance IsStructure [Structure] where
+  toStructure [s] = s
+  toStructure (s1 : s2 : ss) = Merge (Merge s1 s2) (toStructure ss)
+  toStructure [] = Empty
+
+instance IsStructure [Text] where
+  toStructure = Line
+
+instance IsStructure Text where
+  toStructure t = toStructure [t]
+
+data Structure = Line [Text]
+               | Indent Structure
+               | Merge Structure Structure
+               | Empty
+
+structureToText :: Structure -> Text
+structureToText = T.concat . toText ""
+  where toText :: Text -> Structure -> [Text]
+        toText indent = \case
+          Line ts ->
+            indent : ts ++ ["\n"]
+          Indent s ->
+             toText (T.append indent "  ") s
+          Merge a b ->
+            toText indent a ++ toText indent b
+          Empty ->
+            []
+
+(>:) :: (IsStructure a, IsStructure b) => a -> b -> Structure
+a >: b = Merge (toStructure a) (toStructure b)
+
+(>>:) :: (IsStructure a, IsStructure b) => a -> b -> Structure
+a >>: b = Merge (toStructure a) (Indent (toStructure b))
+
+type AtomEntry = ((Text, Date), String)
+
+urlRoot :: Text
+urlRoot = "https://mad.metanohi.name"
+
+generateAtomStructure :: Date -> [AtomEntry] -> Structure
+generateAtomStructure updated entries =
+  "<?xml version=\"1.0\" encoding=\"utf-8\"?>" >:
+  "<feed xmlns=\"http://www.w3.org/2005/Atom\">"
+  >>: ("<title>Niels' mad</title>" >:
+       ["<link href=\"", urlRoot, "/atom.xml\" rel=\"self\" />"] >:
+       ["<link href=\"", urlRoot, "\" />"] >:
+       ["<id>", urlRoot, "/atom.xml</id>"] >:
+       "<author>"
+       >>: ("<name>Niels G. W. Serup</name>" >:
+            "<email>ngws@metanohi.name</email>") >:
+       "</author>" >:
+       ["<updated>", formatDateShort updated, "T00:00:00Z</updated>"])
+  >>: map makeEntry entries >:
+  "</feed>"
+
+makeEntry :: AtomEntry -> Structure
+makeEntry ((title, updated), slug) =
+  "<entry>"
+  >>: (["<title>", title, "</title>"]
+       >: ("<link href=\"" : slugUrl ++ ["\" />"])
+       >: ("<id>" : slugUrl ++ ["</id>"])
+       >: ("<updated>" : updatedDate ++ ["</updated>"])
+       >: ("<published>" : updatedDate ++ ["</published>"]))
+  >: "</entry>"
+  where slugUrl = [urlRoot, "/", T.pack slug, ".html"]
+        updatedDate = [formatDateShort updated, "T00:00:00Z"]
+
+generateAtom :: (TokenableTo Date a, TokenableTo [AtomEntry] b) => a -> b -> DepGenM (Token Text)
+generateAtom = onTupleToken (\updated entries ->
+                               structureToText $ generateAtomStructure updated entries)

byg/src/Byg/Functions/Date.hs

@@ -0,0 +1,26 @@
+module Byg.Functions.Date
+  ( extractDate
+  ) where
+
+import Byg.Types (Token, Date(..))
+import Byg.DependencyGenerator (DepGenM, TokenableTo(..), onToken)
+
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
+
+split :: Eq a => a -> [a] -> NonEmpty [a]
+split sep = \case
+  [] ->
+    NE.singleton []
+  (c : cs) ->
+    (if sep == c
+     then NE.cons []
+     else \(h :| t) -> (c : h) :| t)
+    $ split sep cs
+
+extractDate :: TokenableTo String a => a -> DepGenM (Token Date)
+extractDate = onToken $ \dirName -> case split '-' dirName of
+  year :| (month : day : _) ->
+    Date (read year) (read month) (read day)
+  _ ->
+    error "unexpected"

byg/src/Byg/Functions/Image.hs

@@ -0,0 +1,59 @@
+module Byg.Functions.Image
+  ( Image(..)
+  , ImageConversionSettings(..)
+  , openImage
+  , saveImage
+  , convertImage
+  ) where
+
+import Byg.Types (IsFunctionIO(..), Token(..))
+import Byg.DependencyGenerator (DepGenM, TokenableTo(..), onTupleToken, toTupleToken,
+                            runFunctionIO, runFunctionIO_)
+import Byg.DependencyRunner (extractSndTokenAsList)
+
+import qualified Codec.Picture as CP
+import qualified Codec.Picture.STBIR as CPS
+
+
+newtype Image = ImageWrapper (CP.Image CP.PixelRGB8)
+  deriving (Eq)
+
+instance Show Image where
+  show = const "<image>"
+
+data ImageConversionSettings = ResizeToWidth Int
+  deriving (Eq, Show)
+
+data OpenImage = OpenImage deriving Show
+instance IsFunctionIO OpenImage FilePath Image where
+  evalFunctionIO OpenImage s = do
+    imageOrig <- CP.readImage s
+    case imageOrig of
+      Left e -> error ("unexpected error: " ++ e)
+      Right image -> pure $ ImageWrapper $ CP.convertRGB8 image
+  functionIOReads OpenImage s = [s]
+  functionIOWrites OpenImage = const (ListToken [])
+  functionIOWritesAny OpenImage = False
+
+openImage :: TokenableTo FilePath a => a -> DepGenM (Token Image)
+openImage a = runFunctionIO OpenImage =<< toToken a
+
+
+data SaveImage = SaveImage deriving Show
+instance IsFunctionIO SaveImage (Image, FilePath) () where
+  evalFunctionIO SaveImage (ImageWrapper image, s) =
+    CP.saveJpgImage 90 s $ CP.ImageRGB8 image
+  functionIOReads SaveImage = const []
+  functionIOWrites SaveImage = extractSndTokenAsList
+  functionIOWritesAny SaveImage = True
+
+saveImage :: (TokenableTo Image a, TokenableTo FilePath b) => a -> b -> DepGenM ()
+saveImage a b = runFunctionIO_ SaveImage =<< toTupleToken a b
+
+
+convertImage :: (TokenableTo Image a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM (Token Image)
+convertImage = onTupleToken $ \(ImageWrapper image) (ResizeToWidth widthResized) ->
+  let sizeFactor :: Double
+      sizeFactor = fromIntegral (CP.imageWidth image) / fromIntegral widthResized
+      heightResized = round (fromIntegral (CP.imageHeight image) / sizeFactor)
+  in ImageWrapper $ CPS.resize CPS.defaultOptions widthResized heightResized image

byg/src/Byg/Functions/Pandoc.hs

@@ -0,0 +1,42 @@
+module Byg.Functions.Pandoc
+  ( readMarkdown
+  , writeHtml
+  , markdownToHtml
+  , extractTitle
+  , injectAfterTitle
+  ) where
+
+import Byg.Types (Token)
+import Byg.DependencyGenerator (DepGenM, TokenableTo(..), onToken, onTupleToken)
+
+import Data.Text (Text)
+import Control.Monad ((>=>))
+import Text.Pandoc.Definition (Pandoc)
+import qualified Text.Pandoc.Definition as PD
+import qualified Text.Pandoc.Shared as PS
+import qualified Text.Pandoc as P
+
+runPandoc :: P.PandocPure a -> a
+runPandoc m = case P.runPure m of
+  Left e -> error ("unexpected pandoc error: " ++ show e)
+  Right result -> result
+
+readMarkdown :: TokenableTo Text a => a -> DepGenM (Token Pandoc)
+readMarkdown = onToken $ runPandoc . P.readMarkdown settings
+  where settings = P.def { P.readerExtensions = P.extensionsFromList [ P.Ext_raw_html ] }
+
+writeHtml :: TokenableTo Pandoc a => a -> DepGenM (Token Text)
+writeHtml = onToken $ runPandoc . P.writeHtml5String P.def
+
+markdownToHtml :: TokenableTo Text a => a -> DepGenM (Token Text)
+markdownToHtml = readMarkdown >=> writeHtml
+
+extractTitle :: TokenableTo Pandoc a => a -> DepGenM (Token Text)
+extractTitle = onToken $ \(PD.Pandoc _ blocks) -> case blocks of
+  (PD.Header 1 _ inlines : _) -> PS.stringify inlines
+  _ -> error "unexpected"
+
+injectAfterTitle :: (TokenableTo Text a, TokenableTo Pandoc b) => a -> b -> DepGenM (Token Pandoc)
+injectAfterTitle = onTupleToken $ \extra (PD.Pandoc meta blocks) -> case blocks of
+  (header@(PD.Header _ _ _) : rest) -> PD.Pandoc meta (header : PD.RawBlock "html" extra : rest)
+  _ -> error "unexpected"

byg/src/Byg/Functions/Paths.hs

@@ -0,0 +1,94 @@
+module Byg.Functions.Paths
+  ( joinPaths
+  , fileComponents
+  , hasExtension
+  , listDirectory
+  , isDirectory
+  , makeDir
+  , copyFile
+  , copyTo
+  ) where
+
+import Byg.Types (IsFunctionIO(..), Token(..))
+import Byg.DependencyGenerator (DepGenM, TokenableTo(..), onToken, onTupleToken, toTupleToken,
+                            runFunctionIO, runFunctionIO_, untupleSndDepGenM)
+import Byg.DependencyRunner (extractSndTokenAsList)
+
+import Data.Char (toLower)
+import Control.Monad (when)
+import qualified System.Directory as SD
+
+joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM (Token FilePath)
+joinPaths = onTupleToken $ \s0 s1 -> s0 ++ "/" ++ s1
+
+fileComponents :: TokenableTo FilePath a => a -> DepGenM (Token (String, String))
+fileComponents = onToken $ \s ->
+  let (lastRev, firstRev) = span (/= '.') $ reverse s
+      (base, ext) = case firstRev of
+        _ : firstRev' -> (reverse firstRev', reverse lastRev)
+        [] -> (reverse lastRev, "")
+  in (base, ext)
+
+hasExtension :: (TokenableTo [String] a, TokenableTo FilePath b) => a -> b -> DepGenM (Token Bool)
+hasExtension exts filename = do
+  ext <- onToken (map toLower) =<< untupleSndDepGenM =<< fileComponents filename
+  onTupleToken elem ext exts
+
+
+data ListDirectory = ListDirectory deriving Show
+instance IsFunctionIO ListDirectory FilePath [FilePath] where
+  evalFunctionIO ListDirectory s = SD.listDirectory s
+  functionIOReads ListDirectory s = [s]
+  functionIOWrites ListDirectory = const (ListToken [])
+  functionIOWritesAny ListDirectory = False  -- old: force triggering
+
+listDirectory :: TokenableTo FilePath a => a -> DepGenM (Token [FilePath])
+listDirectory a = runFunctionIO ListDirectory =<< toToken a
+
+
+data IsDirectory = IsDirectory deriving Show
+instance IsFunctionIO IsDirectory FilePath Bool where
+  evalFunctionIO IsDirectory s = SD.doesDirectoryExist s
+  functionIOReads IsDirectory s = [s]
+  functionIOWrites IsDirectory = const (ListToken [])
+  functionIOWritesAny IsDirectory = False
+
+isDirectory :: TokenableTo FilePath a => a -> DepGenM (Token Bool)
+isDirectory a = runFunctionIO IsDirectory =<< toToken a
+
+
+data MakeDir = MakeDir deriving Show
+instance IsFunctionIO MakeDir FilePath () where
+  evalFunctionIO MakeDir s = do
+    exists <- SD.doesPathExist s
+    when (not exists) $ SD.createDirectory s
+  functionIOReads MakeDir = const []
+  functionIOWrites MakeDir s = ListToken [s]
+
+
+  -- Old: Don't consider a created
+                                            -- directory "written", as there is
+                                            -- no extra information than its name
+                                            -- and presence.
+  functionIOWritesAny MakeDir = True
+
+makeDir :: TokenableTo FilePath a => a -> DepGenM ()
+makeDir a = runFunctionIO_ MakeDir =<< toToken a
+
+
+data CopyFile = CopyFile deriving Show
+instance IsFunctionIO CopyFile (FilePath, FilePath) () where
+  evalFunctionIO CopyFile (source, target) =
+    SD.copyFile source target
+  functionIOReads CopyFile (i, _) = [i]
+  functionIOWrites CopyFile = extractSndTokenAsList
+  functionIOWritesAny CopyFile = True
+
+copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM ()
+copyFile a b = runFunctionIO_ CopyFile =<< toTupleToken a b
+
+copyTo :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM ()
+copyTo path targetDir = do
+  pathToken <- toToken path
+  copyFile pathToken =<< joinPaths targetDir pathToken
+

byg/src/Byg/Functions/Template.hs

@@ -0,0 +1,24 @@
+module Byg.Functions.Template
+  ( Template(..)
+  , makeTemplate
+  , applyTemplate
+  ) where
+
+import Byg.Types (Token)
+import Byg.DependencyGenerator (DepGenM, TokenableTo(..), onTupleToken)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+data Template = TemplateParts Text Text
+  deriving (Eq, Show)
+
+makeTemplate :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM (Token Template)
+makeTemplate = onTupleToken $ \t c ->
+  let (beforeContent, after) = T.breakOn c t
+      afterContent = T.drop (T.length c) after
+  in TemplateParts beforeContent afterContent
+
+applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGenM (Token Text)
+applyTemplate = onTupleToken $ \(TemplateParts beforeContent afterContent) t ->
+  T.concat [beforeContent, t, afterContent]

byg/src/Byg/Functions/Text.hs

@@ -0,0 +1,33 @@
+module Byg.Functions.Text
+  ( readTextFile
+  , saveTextFile
+  ) where
+
+import Byg.Types (IsFunctionIO(..), Token(..))
+import Byg.DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken,
+                            runFunctionIO, runFunctionIO_)
+import Byg.DependencyRunner (extractSndTokenAsList)
+
+import Data.Text (Text)
+import qualified Data.Text.IO as T
+
+data ReadTextFile = ReadTextFile deriving Show
+instance IsFunctionIO ReadTextFile FilePath Text where
+  evalFunctionIO ReadTextFile s = T.readFile s
+  functionIOReads ReadTextFile s = [s]
+  functionIOWrites ReadTextFile  = const (ListToken [])
+  functionIOWritesAny ReadTextFile = False
+
+readTextFile :: TokenableTo FilePath a => a -> DepGenM (Token Text)
+readTextFile a = runFunctionIO ReadTextFile =<< toToken a
+
+
+data SaveTextFile = SaveTextFile deriving Show
+instance IsFunctionIO SaveTextFile (Text, FilePath) () where
+  evalFunctionIO SaveTextFile (t, s) = T.writeFile s t
+  functionIOReads SaveTextFile = const []
+  functionIOWrites SaveTextFile = extractSndTokenAsList
+  functionIOWritesAny SaveTextFile = True
+
+saveTextFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM ()
+saveTextFile a b = runFunctionIO_ SaveTextFile =<< toTupleToken a b