Curry more
This commit is contained in:
parent
831ab700b9
commit
b60336cf9f
|
|
@ -9,6 +9,7 @@ module DependencyGenerator
|
|||
, mapDepGenM
|
||||
, mapDepGenM_
|
||||
, filterDepGenM
|
||||
, zipDepGenM
|
||||
, untupleFstDepGenM
|
||||
, untupleSndDepGenM
|
||||
, untupleDepGenM
|
||||
|
|
@ -92,24 +93,34 @@ runFunctionIO f input = genDependency (makeDependency input (FunctionIO f))
|
|||
runFunctionIO' :: FunctionIO -> Token a -> DepGenM ()
|
||||
runFunctionIO' f input = tellDep $ makeDependency input (FunctionIO f) NoToken
|
||||
|
||||
mapDepGenM :: (Token a -> DepGenM' b) -> Token [a] -> DepGenM' [b]
|
||||
mapDepGenM f input = genDependencyM $ \target -> do
|
||||
mapDepGenM :: TokenableTo [a] v => (Token a -> DepGenM' b) -> v -> DepGenM' [b]
|
||||
mapDepGenM f input = do
|
||||
input' <- toToken input
|
||||
genDependencyM $ \target -> do
|
||||
top <- get
|
||||
let (res, top') = evalDepGenM' top $ do
|
||||
inp <- getListElem input
|
||||
inp <- getListElem input'
|
||||
outp <- f inp
|
||||
setListElem outp target
|
||||
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 (\x -> f x >> pure NoToken) input
|
||||
pure ()
|
||||
|
||||
filterDepGenM :: Token [Bool] -> Token [a] -> DepGenM' [a]
|
||||
filterDepGenM :: (TokenableTo [Bool] v, TokenableTo [a] u) => v -> u -> DepGenM' [a]
|
||||
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 t = do
|
||||
|
|
@ -162,8 +173,8 @@ 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
|
||||
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')
|
||||
|
|
@ -171,8 +182,8 @@ appendStrings (a, b) = do
|
|||
concatStrings :: TokenableTo [String] a => a -> DepGenM' String
|
||||
concatStrings a = runFunction ConcatStrings =<< toToken a
|
||||
|
||||
appendTexts :: (TokenableTo Text a, TokenableTo Text b) => (a, b) -> DepGenM' Text
|
||||
appendTexts (a, b) = do
|
||||
appendTexts :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM' Text
|
||||
appendTexts a b = do
|
||||
a' <- toToken a
|
||||
b' <- toToken b
|
||||
runFunction AppendTexts $ TupleToken (a', b')
|
||||
|
|
@ -180,8 +191,8 @@ appendTexts (a, b) = do
|
|||
concatTexts :: TokenableTo [Text] a => a -> DepGenM' Text
|
||||
concatTexts a = runFunction ConcatTexts =<< toToken a
|
||||
|
||||
joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => (a, b) -> DepGenM' FilePath
|
||||
joinPaths (a, b) = do
|
||||
joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM' FilePath
|
||||
joinPaths a b = do
|
||||
a' <- toToken a
|
||||
b' <- toToken b
|
||||
runFunction JoinPaths $ TupleToken (a', b')
|
||||
|
|
@ -192,8 +203,8 @@ fileComponents a = runFunction FileComponents =<< toToken a
|
|||
isImageExtension :: TokenableTo FilePath a => a -> DepGenM' Bool
|
||||
isImageExtension a = runFunction IsImageExtension =<< toToken a
|
||||
|
||||
applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => (a, b) -> DepGenM' Text
|
||||
applyTemplate (a, b) = do
|
||||
applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGenM' Text
|
||||
applyTemplate a b = do
|
||||
a' <- toToken a
|
||||
b' <- toToken b
|
||||
runFunction ApplyTemplate $ TupleToken (a', b')
|
||||
|
|
@ -207,20 +218,20 @@ listDirectory a = runFunctionIO ListDirectory =<< toToken a
|
|||
readTemplate :: TokenableTo FilePath a => a -> DepGenM' Template
|
||||
readTemplate a = runFunctionIO ReadTemplate =<< toToken a
|
||||
|
||||
convertImage :: (TokenableTo (FilePath, FilePath) a, TokenableTo ImageConversionSettings b) => (a, b) -> DepGenM ()
|
||||
convertImage (a, b) = do
|
||||
convertImage :: (TokenableTo (FilePath, FilePath) a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM ()
|
||||
convertImage a b = do
|
||||
a' <- toToken a
|
||||
b' <- toToken b
|
||||
runFunctionIO' ConvertImage $ TupleToken (a', b')
|
||||
|
||||
saveFile :: (TokenableTo Text a, TokenableTo FilePath b) => (a, b) -> DepGenM ()
|
||||
saveFile (a, b) = do
|
||||
saveFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM ()
|
||||
saveFile a b = do
|
||||
a' <- toToken a
|
||||
b' <- toToken b
|
||||
runFunctionIO' SaveFile $ TupleToken (a', b')
|
||||
|
||||
copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => (a, b) -> DepGenM ()
|
||||
copyFile (a, b) = do
|
||||
copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM ()
|
||||
copyFile a b = do
|
||||
a' <- toToken a
|
||||
b' <- toToken b
|
||||
runFunctionIO' CopyFile $ TupleToken (a', b')
|
||||
|
|
|
|||
|
|
@ -8,58 +8,58 @@ import Data.Text (Text)
|
|||
|
||||
thumbnailImageFilename :: Token FilePath -> DepGenM' FilePath
|
||||
thumbnailImageFilename filename = do
|
||||
(base, ext) <- untupleDepGenM (fileComponents filename)
|
||||
appendStrings (appendStrings (base, inject "-thumbnail."), ext)
|
||||
(base, ext) <- untupleDepGenM $ fileComponents filename
|
||||
appendStrings base
|
||||
$ appendStrings (inject "-thumbnail.") ext
|
||||
|
||||
makeImageHTML :: Token (FilePath, FilePath) -> DepGenM' Text
|
||||
makeImageHTML t = do
|
||||
(thumbnail, actual) <- untupleDepGenM t
|
||||
appendTexts (
|
||||
inject "<p><a href=\"",
|
||||
appendTexts (
|
||||
toText actual,
|
||||
appendTexts (
|
||||
inject "\"><img src=\"",
|
||||
appendTexts (
|
||||
toText thumbnail,
|
||||
inject "\"></a></p>"))))
|
||||
appendTexts
|
||||
(inject "<p><a href=\"")
|
||||
(appendTexts
|
||||
(toText actual)
|
||||
(appendTexts
|
||||
(inject "\"><img src=\"")
|
||||
(appendTexts
|
||||
(toText thumbnail)
|
||||
(inject "\"></a></p>"))))
|
||||
|
||||
handleRecipeDir :: Token FilePath -> Token Template -> Token FilePath -> Token FilePath -> DepGenM ()
|
||||
handleRecipeDir outputDir template indexName dir = do
|
||||
recipeDirOut <- joinPaths (outputDir, dir)
|
||||
recipeDirOut <- joinPaths outputDir dir
|
||||
makeDir recipeDirOut
|
||||
dirContents <- listDirectory dir
|
||||
exts <- unzipSndDepGenM (mapDepGenM fileComponents dirContents)
|
||||
areImageFilenames <- mapDepGenM isImageExtension exts
|
||||
areImageFilenames <- mapDepGenM isImageExtension
|
||||
$ unzipSndDepGenM $ mapDepGenM fileComponents dirContents
|
||||
imageFilenames <- filterDepGenM areImageFilenames dirContents
|
||||
imagePaths <- mapDepGenM (curry joinPaths dir) imageFilenames
|
||||
imagePathsOut <- mapDepGenM (curry joinPaths recipeDirOut) imageFilenames
|
||||
mapDepGenM_ copyFile' (ZipToken (imagePaths, imagePathsOut))
|
||||
imagePaths <- mapDepGenM (joinPaths dir) imageFilenames
|
||||
imagePathsOut <- mapDepGenM (joinPaths recipeDirOut) imageFilenames
|
||||
mapDepGenM_ copyFile' $ zipDepGenM imagePaths imagePathsOut
|
||||
thumbnailImageFilenames <- mapDepGenM thumbnailImageFilename imageFilenames
|
||||
thumbnailImagePaths <- mapDepGenM (curry joinPaths recipeDirOut) thumbnailImageFilenames
|
||||
thumbnailImagePaths <- mapDepGenM (joinPaths recipeDirOut) thumbnailImageFilenames
|
||||
mapDepGenM_
|
||||
(\files -> convertImage (files, inject $ ResizeToWidth 800))
|
||||
(ZipToken (imagePaths, thumbnailImagePaths))
|
||||
htmlBodyBase <- runPandoc (joinPaths (dir, inject "ret.md"))
|
||||
htmlBodyImages <- mapDepGenM makeImageHTML (ZipToken (thumbnailImageFilenames, imageFilenames))
|
||||
(\files -> convertImage files $ inject $ ResizeToWidth 800)
|
||||
(zipDepGenM imagePaths thumbnailImagePaths)
|
||||
htmlBodyBase <- runPandoc $ joinPaths dir $ inject "ret.md"
|
||||
htmlBodyImages <- mapDepGenM makeImageHTML $ zipDepGenM thumbnailImageFilenames imageFilenames
|
||||
imagesHtml <- concatTexts htmlBodyImages
|
||||
htmlBody <- appendTexts (htmlBodyBase, imagesHtml)
|
||||
html <- applyTemplate (template, htmlBody)
|
||||
saveFile (html, joinPaths (recipeDirOut, indexName))
|
||||
htmlBody <- appendTexts htmlBodyBase imagesHtml
|
||||
html <- applyTemplate template htmlBody
|
||||
saveFile html $ joinPaths recipeDirOut indexName
|
||||
|
||||
generateSite :: DepGenM ()
|
||||
generateSite = do
|
||||
outputDir <- inject "site"
|
||||
makeDir outputDir
|
||||
recipesDir <- inject "retter"
|
||||
outputRecipesDir <- joinPaths (outputDir, recipesDir)
|
||||
outputRecipesDir <- joinPaths outputDir recipesDir
|
||||
makeDir outputRecipesDir
|
||||
template <- readTemplate (inject "template.html")
|
||||
template <- readTemplate $ inject "template.html"
|
||||
indexName <- inject "index.html"
|
||||
dirContents <- listDirectory recipesDir
|
||||
mapDepGenM_ (handleRecipeDir outputRecipesDir template indexName) dirContents
|
||||
htmlBody <- runPandoc (inject "om.md")
|
||||
html <- applyTemplate (template, htmlBody)
|
||||
aboutDir <- joinPaths (outputDir, inject "om")
|
||||
html <- applyTemplate template $ runPandoc $ inject "om.md"
|
||||
aboutDir <- joinPaths outputDir $ inject "om"
|
||||
makeDir aboutDir
|
||||
saveFile (html, joinPaths (aboutDir, indexName))
|
||||
saveFile html $ joinPaths aboutDir indexName
|
||||
|
|
|
|||
Loading…
Reference in New Issue