From 992edea3ee9b2241452a3ab6ef46c8369912907d Mon Sep 17 00:00:00 2001
From: "Niels G. W. Serup" <ngws@metanohi.name>
Date: Wed, 25 Sep 2024 23:32:49 +0200
Subject: [PATCH] Implement untupling and use more general append instead of
 ConvertedImageFilename

---
 byg/src/DependencyGenerator.hs | 35 ++++++++++++++++++++++++++++++----
 byg/src/Evaluation/Function.hs |  6 +++---
 byg/src/SiteGenerator.hs       |  9 +++++++--
 byg/src/Types/Dependency.hs    |  2 ++
 byg/src/Types/Function.hs      |  4 ++--
 5 files changed, 45 insertions(+), 11 deletions(-)

diff --git a/byg/src/DependencyGenerator.hs b/byg/src/DependencyGenerator.hs
index bfb2704..6d3ab1d 100644
--- a/byg/src/DependencyGenerator.hs
+++ b/byg/src/DependencyGenerator.hs
@@ -9,14 +9,17 @@ module DependencyGenerator
   , mapDepGenM
   , mapDepGenM_
   , filterDepGenM
+  , untupleFstDepGenM
+  , untupleSndDepGenM
+  , untupleDepGenM
   , unzipFstDepGenM
   , unzipSndDepGenM
   , unzipDepGenM
 
+  , appendStrings
   , joinPaths
   , fileComponents
   , isImageExtension
-  , convertedImageFilename
   , applyTemplate
   , listDirectory
   , readTemplate
@@ -101,6 +104,27 @@ filterDepGenM :: Token [Bool] -> Token [a] -> DepGenM' [a]
 filterDepGenM mask input = do
   genDependency (makeDependency (TupleToken (input, mask)) FilterComp)
 
+untupleFstDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token a)
+untupleFstDepGenM t = do
+  t' <- toToken t
+  case t' of
+    TupleToken (a, _) -> pure a
+    Token _ -> genDependency (makeDependency t' UntupleFst)
+
+untupleSndDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token b)
+untupleSndDepGenM t = do
+  t' <- toToken t
+  case t' of
+    TupleToken (_, b) -> pure b
+    Token _ -> genDependency (makeDependency t' UntupleSnd)
+
+untupleDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token a, Token b)
+untupleDepGenM t = do
+  t' <- toToken t
+  a <- untupleFstDepGenM t'
+  b <- untupleSndDepGenM t'
+  pure (a, b)
+
 unzipFstDepGenM :: TokenableTo [(a, b)] t => t -> DepGenM (Token [a])
 unzipFstDepGenM t = do
   t' <- toToken t
@@ -131,6 +155,12 @@ instance TokenableTo a (Token a) where
 instance TokenableTo a (DepGenM' a) where
   toToken = id
 
+appendStrings :: (TokenableTo String a, TokenableTo String b) => (a, b) -> DepGenM' String
+appendStrings (a, b) = do
+  a' <- toToken a
+  b' <- toToken b
+  runFunction AppendStrings $ TupleToken (a', b')
+
 joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => (a, b) -> DepGenM' FilePath
 joinPaths (a, b) = do
   a' <- toToken a
@@ -143,9 +173,6 @@ fileComponents a = runFunction FileComponents =<< toToken a
 isImageExtension :: TokenableTo FilePath a => a -> DepGenM' Bool
 isImageExtension a = runFunction IsImageExtension =<< toToken a
 
-convertedImageFilename :: TokenableTo FilePath a => a -> DepGenM' FilePath
-convertedImageFilename a = runFunction ConvertedImageFilename =<< toToken a
-
 applyTemplate :: (TokenableTo Template a, TokenableTo String b) => (a, b) -> DepGenM' String
 applyTemplate (a, b) = do
   a' <- toToken a
diff --git a/byg/src/Evaluation/Function.hs b/byg/src/Evaluation/Function.hs
index 9b67cbd..da6dd95 100644
--- a/byg/src/Evaluation/Function.hs
+++ b/byg/src/Evaluation/Function.hs
@@ -6,6 +6,9 @@ import Types (Function(..), Value(..))
 
 evalFunction :: Function -> Value -> Value
 evalFunction f x = case (f, x) of
+  (AppendStrings, Tuple (String _, String _)) ->
+    String undefined
+
   (JoinPaths, Tuple (String _, String _)) ->
     String undefined
 
@@ -15,9 +18,6 @@ evalFunction f x = case (f, x) of
   (IsImageExtension, String _) ->
     Bool undefined
 
-  (ConvertedImageFilename, String _) ->
-    String undefined
-
   (ApplyTemplate, Tuple (Template _, String _)) ->
     String undefined
 
diff --git a/byg/src/SiteGenerator.hs b/byg/src/SiteGenerator.hs
index 24c7c21..0adf745 100644
--- a/byg/src/SiteGenerator.hs
+++ b/byg/src/SiteGenerator.hs
@@ -3,16 +3,21 @@ module SiteGenerator (generateSite) where
 import Types
 import DependencyGenerator
 
+thumbnailImageFilename :: Token FilePath -> DepGenM' FilePath
+thumbnailImageFilename filename = do
+  (base, ext) <- untupleDepGenM (fileComponents filename)
+  appendStrings (appendStrings (base, inject "-thumbnail."), ext)
+
 handleRecipeDir :: Token FilePath -> Token Template -> Token FilePath -> DepGenM ()
 handleRecipeDir outputDir template dir = do
   dirContents <- listDirectory dir
   exts <- unzipSndDepGenM (mapDepGenM fileComponents dirContents)
   areImageFilenames <- mapDepGenM isImageExtension exts
   imageFilenames <- filterDepGenM areImageFilenames dirContents
-  convertedImageFilenames <- mapDepGenM convertedImageFilename imageFilenames
+  thumbnailImageFilenames <- mapDepGenM thumbnailImageFilename imageFilenames
   mapDepGenM_
     (\files -> convertImage (files, inject $ ResizeToWidth 800))
-    (ZipToken (imageFilenames, convertedImageFilenames))
+    (ZipToken (imageFilenames, thumbnailImageFilenames))
   recipeDirOut <- joinPaths (outputDir, dir)
   makeDir recipeDirOut
   htmlBody <- runPandoc (joinPaths (dir, inject "ret.md"))
diff --git a/byg/src/Types/Dependency.hs b/byg/src/Types/Dependency.hs
index 2725acc..f1c1e51 100644
--- a/byg/src/Types/Dependency.hs
+++ b/byg/src/Types/Dependency.hs
@@ -23,6 +23,8 @@ data Action = Function Function
             | FilterComp
             | GetListElem
             | SetListElem
+            | UntupleFst
+            | UntupleSnd
             | UnzipFst
             | UnzipSnd
             | MapComp [Dependency]
diff --git a/byg/src/Types/Function.hs b/byg/src/Types/Function.hs
index 8921677..87d2a9f 100644
--- a/byg/src/Types/Function.hs
+++ b/byg/src/Types/Function.hs
@@ -4,10 +4,10 @@ module Types.Function
 
 import Language.Haskell.TH.Syntax (Lift)
 
-data Function = JoinPaths
+data Function = AppendStrings
+              | JoinPaths
               | FileComponents
               | IsImageExtension
-              | ConvertedImageFilename
               | ApplyTemplate
   deriving (Show, Lift)