ngws
/
mad
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Curry more

This commit is contained in:
Niels G. W. Serup 2024-09-26 23:40:26 +02:00
parent 831ab700b9
commit b60336cf9f
No known key found for this signature in database
GPG Key ID: 38EEEBCE67324F19
2 changed files with 68 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
byg/src/DependencyGenerator.hs
View File

@ -9,6 +9,7 @@ module DependencyGenerator
, mapDepGenM , mapDepGenM
, mapDepGenM_ , mapDepGenM_
, filterDepGenM , filterDepGenM
, zipDepGenM
, untupleFstDepGenM , untupleFstDepGenM
, untupleSndDepGenM , untupleSndDepGenM
, untupleDepGenM , untupleDepGenM
@ -92,24 +93,34 @@ runFunctionIO f input = genDependency (makeDependency input (FunctionIO f))
runFunctionIO' :: FunctionIO -> Token a -> DepGenM () runFunctionIO' :: FunctionIO -> Token a -> DepGenM ()
runFunctionIO' f input = tellDep $ makeDependency input (FunctionIO f) NoToken runFunctionIO' f input = tellDep $ makeDependency input (FunctionIO f) NoToken
mapDepGenM :: (Token a -> DepGenM' b) -> Token [a] -> DepGenM' [b] mapDepGenM :: TokenableTo [a] v => (Token a -> DepGenM' b) -> v -> DepGenM' [b]
mapDepGenM f input = genDependencyM $ \target -> do mapDepGenM f input = do
input' <- toToken input
genDependencyM $ \target -> do
top <- get top <- get
let (res, top') = evalDepGenM' top $ do let (res, top') = evalDepGenM' top $ do
inp <- getListElem input inp <- getListElem input'
outp <- f inp outp <- f inp
setListElem outp target setListElem outp target
put top' put top'
pure (makeDependency input (MapComp res) target) pure (makeDependency input' (MapComp res) target)
mapDepGenM_ :: (Token a -> DepGenM ()) -> Token [a] -> DepGenM () mapDepGenM_ :: TokenableTo [a] v => (Token a -> DepGenM ()) -> v -> DepGenM ()
mapDepGenM_ f input = do mapDepGenM_ f input = do
_ <- mapDepGenM (\x -> f x >> pure NoToken) input _ <- mapDepGenM (\x -> f x >> pure NoToken) input
pure () pure ()
filterDepGenM :: Token [Bool] -> Token [a] -> DepGenM' [a] filterDepGenM :: (TokenableTo [Bool] v, TokenableTo [a] u) => v -> u -> DepGenM' [a]
filterDepGenM mask input = do filterDepGenM mask input = do
genDependency (makeDependency (TupleToken (input, mask)) FilterComp) mask' <- toToken mask
input' <- toToken input
genDependency (makeDependency (TupleToken (input', mask')) FilterComp)
zipDepGenM :: (TokenableTo [a] v, TokenableTo [b] u) => v -> u -> DepGenM' [(a, b)]
zipDepGenM a b = do
a' <- toToken a
b' <- toToken b
pure $ ZipToken (a', b')
untupleFstDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token a) untupleFstDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token a)
untupleFstDepGenM t = do untupleFstDepGenM t = do
@ -162,8 +173,8 @@ instance TokenableTo a (Token a) where
instance TokenableTo a (DepGenM' a) where instance TokenableTo a (DepGenM' a) where
toToken = id toToken = id
appendStrings :: (TokenableTo String a, TokenableTo String b) => (a, b) -> DepGenM' String appendStrings :: (TokenableTo String a, TokenableTo String b) => a -> b -> DepGenM' String
appendStrings (a, b) = do appendStrings a b = do
a' <- toToken a a' <- toToken a
b' <- toToken b b' <- toToken b
runFunction AppendStrings $ TupleToken (a', b') runFunction AppendStrings $ TupleToken (a', b')
@ -171,8 +182,8 @@ appendStrings (a, b) = do
concatStrings :: TokenableTo [String] a => a -> DepGenM' String concatStrings :: TokenableTo [String] a => a -> DepGenM' String
concatStrings a = runFunction ConcatStrings =<< toToken a concatStrings a = runFunction ConcatStrings =<< toToken a
appendTexts :: (TokenableTo Text a, TokenableTo Text b) => (a, b) -> DepGenM' Text appendTexts :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM' Text
appendTexts (a, b) = do appendTexts a b = do
a' <- toToken a a' <- toToken a
b' <- toToken b b' <- toToken b
runFunction AppendTexts $ TupleToken (a', b') runFunction AppendTexts $ TupleToken (a', b')
@ -180,8 +191,8 @@ appendTexts (a, b) = do
concatTexts :: TokenableTo [Text] a => a -> DepGenM' Text concatTexts :: TokenableTo [Text] a => a -> DepGenM' Text
concatTexts a = runFunction ConcatTexts =<< toToken a concatTexts a = runFunction ConcatTexts =<< toToken a
joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => (a, b) -> DepGenM' FilePath joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM' FilePath
joinPaths (a, b) = do joinPaths a b = do
a' <- toToken a a' <- toToken a
b' <- toToken b b' <- toToken b
runFunction JoinPaths $ TupleToken (a', b') runFunction JoinPaths $ TupleToken (a', b')
@ -192,8 +203,8 @@ fileComponents a = runFunction FileComponents =<< toToken a
isImageExtension :: TokenableTo FilePath a => a -> DepGenM' Bool isImageExtension :: TokenableTo FilePath a => a -> DepGenM' Bool
isImageExtension a = runFunction IsImageExtension =<< toToken a isImageExtension a = runFunction IsImageExtension =<< toToken a
applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => (a, b) -> DepGenM' Text applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGenM' Text
applyTemplate (a, b) = do applyTemplate a b = do
a' <- toToken a a' <- toToken a
b' <- toToken b b' <- toToken b
runFunction ApplyTemplate $ TupleToken (a', b') runFunction ApplyTemplate $ TupleToken (a', b')
@ -207,20 +218,20 @@ listDirectory a = runFunctionIO ListDirectory =<< toToken a
readTemplate :: TokenableTo FilePath a => a -> DepGenM' Template readTemplate :: TokenableTo FilePath a => a -> DepGenM' Template
readTemplate a = runFunctionIO ReadTemplate =<< toToken a readTemplate a = runFunctionIO ReadTemplate =<< toToken a
convertImage :: (TokenableTo (FilePath, FilePath) a, TokenableTo ImageConversionSettings b) => (a, b) -> DepGenM () convertImage :: (TokenableTo (FilePath, FilePath) a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM ()
convertImage (a, b) = do convertImage a b = do
a' <- toToken a a' <- toToken a
b' <- toToken b b' <- toToken b
runFunctionIO' ConvertImage $ TupleToken (a', b') runFunctionIO' ConvertImage $ TupleToken (a', b')
saveFile :: (TokenableTo Text a, TokenableTo FilePath b) => (a, b) -> DepGenM () saveFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM ()
saveFile (a, b) = do saveFile a b = do
a' <- toToken a a' <- toToken a
b' <- toToken b b' <- toToken b
runFunctionIO' SaveFile $ TupleToken (a', b') runFunctionIO' SaveFile $ TupleToken (a', b')
copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => (a, b) -> DepGenM () copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM ()
copyFile (a, b) = do copyFile a b = do
a' <- toToken a a' <- toToken a
b' <- toToken b b' <- toToken b
runFunctionIO' CopyFile $ TupleToken (a', b') runFunctionIO' CopyFile $ TupleToken (a', b')

62
byg/src/SiteGenerator.hs
View File

@ -8,58 +8,58 @@ import Data.Text (Text)
thumbnailImageFilename :: Token FilePath -> DepGenM' FilePath thumbnailImageFilename :: Token FilePath -> DepGenM' FilePath
thumbnailImageFilename filename = do thumbnailImageFilename filename = do
(base, ext) <- untupleDepGenM (fileComponents filename) (base, ext) <- untupleDepGenM $ fileComponents filename
appendStrings (appendStrings (base, inject "-thumbnail."), ext) appendStrings base
$ appendStrings (inject "-thumbnail.") ext
makeImageHTML :: Token (FilePath, FilePath) -> DepGenM' Text makeImageHTML :: Token (FilePath, FilePath) -> DepGenM' Text
makeImageHTML t = do makeImageHTML t = do
(thumbnail, actual) <- untupleDepGenM t (thumbnail, actual) <- untupleDepGenM t
appendTexts ( appendTexts
inject "<p><a href=\"", (inject "<p><a href=\"")
appendTexts ( (appendTexts
toText actual, (toText actual)
appendTexts ( (appendTexts
inject "\"><img src=\"", (inject "\"><img src=\"")
appendTexts ( (appendTexts
toText thumbnail, (toText thumbnail)
inject "\"></a></p>")))) (inject "\"></a></p>"))))
handleRecipeDir :: Token FilePath -> Token Template -> Token FilePath -> Token FilePath -> DepGenM () handleRecipeDir :: Token FilePath -> Token Template -> Token FilePath -> Token FilePath -> DepGenM ()
handleRecipeDir outputDir template indexName dir = do handleRecipeDir outputDir template indexName dir = do
recipeDirOut <- joinPaths (outputDir, dir) recipeDirOut <- joinPaths outputDir dir
makeDir recipeDirOut makeDir recipeDirOut
dirContents <- listDirectory dir dirContents <- listDirectory dir
exts <- unzipSndDepGenM (mapDepGenM fileComponents dirContents) areImageFilenames <- mapDepGenM isImageExtension
areImageFilenames <- mapDepGenM isImageExtension exts $ unzipSndDepGenM $ mapDepGenM fileComponents dirContents
imageFilenames <- filterDepGenM areImageFilenames dirContents imageFilenames <- filterDepGenM areImageFilenames dirContents
imagePaths <- mapDepGenM (curry joinPaths dir) imageFilenames imagePaths <- mapDepGenM (joinPaths dir) imageFilenames
imagePathsOut <- mapDepGenM (curry joinPaths recipeDirOut) imageFilenames imagePathsOut <- mapDepGenM (joinPaths recipeDirOut) imageFilenames
mapDepGenM_ copyFile' (ZipToken (imagePaths, imagePathsOut)) mapDepGenM_ copyFile' $ zipDepGenM imagePaths imagePathsOut
thumbnailImageFilenames <- mapDepGenM thumbnailImageFilename imageFilenames thumbnailImageFilenames <- mapDepGenM thumbnailImageFilename imageFilenames
thumbnailImagePaths <- mapDepGenM (curry joinPaths recipeDirOut) thumbnailImageFilenames thumbnailImagePaths <- mapDepGenM (joinPaths recipeDirOut) thumbnailImageFilenames
mapDepGenM_ mapDepGenM_
(\files -> convertImage (files, inject $ ResizeToWidth 800)) (\files -> convertImage files $ inject $ ResizeToWidth 800)
(ZipToken (imagePaths, thumbnailImagePaths)) (zipDepGenM imagePaths thumbnailImagePaths)
htmlBodyBase <- runPandoc (joinPaths (dir, inject "ret.md")) htmlBodyBase <- runPandoc $ joinPaths dir $ inject "ret.md"
htmlBodyImages <- mapDepGenM makeImageHTML (ZipToken (thumbnailImageFilenames, imageFilenames)) htmlBodyImages <- mapDepGenM makeImageHTML $ zipDepGenM thumbnailImageFilenames imageFilenames
imagesHtml <- concatTexts htmlBodyImages imagesHtml <- concatTexts htmlBodyImages
htmlBody <- appendTexts (htmlBodyBase, imagesHtml) htmlBody <- appendTexts htmlBodyBase imagesHtml
html <- applyTemplate (template, htmlBody) html <- applyTemplate template htmlBody
saveFile (html, joinPaths (recipeDirOut, indexName)) saveFile html $ joinPaths recipeDirOut indexName
generateSite :: DepGenM () generateSite :: DepGenM ()
generateSite = do generateSite = do
outputDir <- inject "site" outputDir <- inject "site"
makeDir outputDir makeDir outputDir
recipesDir <- inject "retter" recipesDir <- inject "retter"
outputRecipesDir <- joinPaths (outputDir, recipesDir) outputRecipesDir <- joinPaths outputDir recipesDir
makeDir outputRecipesDir makeDir outputRecipesDir
template <- readTemplate (inject "template.html") template <- readTemplate $ inject "template.html"
indexName <- inject "index.html" indexName <- inject "index.html"
dirContents <- listDirectory recipesDir dirContents <- listDirectory recipesDir
mapDepGenM_ (handleRecipeDir outputRecipesDir template indexName) dirContents mapDepGenM_ (handleRecipeDir outputRecipesDir template indexName) dirContents
htmlBody <- runPandoc (inject "om.md") html <- applyTemplate template $ runPandoc $ inject "om.md"
html <- applyTemplate (template, htmlBody) aboutDir <- joinPaths outputDir $ inject "om"
aboutDir <- joinPaths (outputDir, inject "om")
makeDir aboutDir makeDir aboutDir
saveFile (html, joinPaths (aboutDir, indexName)) saveFile html $ joinPaths aboutDir indexName