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

Define shortcut runners the same place as the instances

This commit is contained in:
Niels G. W. Serup 2024-10-06 15:12:31 +02:00
parent 1fce00e531
commit f8e80ae2bc
No known key found for this signature in database
GPG Key ID: 38EEEBCE67324F19
5 changed files with 150 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
byg/byg.cabal
View File

@ -28,6 +28,7 @@ library
Types.Dependency
Types
DependencyGenerator
FunctionIO
Evaluation.Function
DependencyRunner
SiteGenerator

114
byg/src/DependencyGenerator.hs
View File

@ -3,11 +3,13 @@
module DependencyGenerator
( DepGenM
, DepGenM'
, evalDepGenM
, TokenableTo(..)
, toTupleToken
, evalDepGenM
, inject
, runFunction
, runFunctionIO
, runFunctionIO_
, mapDepGenM
, mapDepGenM_
, forDepGenM
@ -34,20 +36,9 @@ module DependencyGenerator
, applyTemplate
, toText
, convertImage
, listDirectory
, isDirectory
, readTextFile
, openImage
, saveImage
, saveTextFile
, copyFile
, copyFile'
, makeDir
, runPandoc
, hasExtension
, copyTo
) where
import Prelude hiding (String, FilePath)
@ -55,8 +46,8 @@ import Prelude hiding (String, FilePath)
import Types.Token (Token(..))
import Types.Values
import Types.Value (Valuable(..))
import Types.FunctionIO (IsFunctionIO(..))
import Types.Function (Function(..))
import Types.FunctionIO
import Types.Dependency (Action(..), Dependency, makeDependency, makeUToken)
import Control.Monad.State (MonadState, State, runState, put, get)
@ -77,7 +68,7 @@ evalDepGenM = snd . fst . runDepGenM 0
tellDep :: Dependency -> DepGenM ()
tellDep dep = tell [dep]
newToken :: DepGenM' a
newToken :: DepGenM (Token a)
newToken = do
top <- get
let top' = top + 1
@ -85,30 +76,30 @@ newToken = do
put top'
pure target
genDependencyM :: (Token a -> DepGenM Dependency) -> DepGenM' a
genDependencyM :: (Token a -> DepGenM Dependency) -> DepGenM (Token a)
genDependencyM f = do
target <- newToken
result <- f target
tellDep result
pure target
genDependency :: (Token a -> Dependency) -> DepGenM' a
genDependency :: (Token a -> Dependency) -> DepGenM (Token a)
genDependency f = genDependencyM (pure . f)
inject :: Valuable a => a -> DepGenM' a
inject :: Valuable a => a -> DepGenM (Token a)
inject x = genDependency (makeDependency NoToken (Inject (toValue x)))
runFunction :: Function -> Token a -> DepGenM' b
runFunction :: Function -> Token a -> DepGenM (Token b)
runFunction f input = genDependency (makeDependency input (Function f))
runFunctionIO :: IsFunctionIO f a b => f -> Token a -> DepGenM' b
runFunctionIO :: IsFunctionIO f a b => f -> Token a -> DepGenM (Token b)
runFunctionIO f input = genDependency (makeDependency input (FunctionIO f))
runFunctionIO_ :: IsFunctionIO f a () => f -> Token a -> DepGenM ()
runFunctionIO_ f input = tellDep $ makeDependency input (FunctionIO f) NoToken
class TokenableTo t s | s -> t where
toToken :: s -> DepGenM' t
toToken :: s -> DepGenM (Token t)
instance TokenableTo a (Token a) where
toToken = pure
@ -116,16 +107,16 @@ instance TokenableTo a (Token a) where
instance TokenableTo [a] [Token a] where
toToken = pure . ListToken
instance TokenableTo [a] [DepGenM' a] where
toToken = fmap ListToken . sequence
instance TokenableTo a (DepGenM' a) where
instance TokenableTo a (DepGenM (Token a)) where
toToken = id
toTupleToken :: (TokenableTo ta a, TokenableTo tb b) => a -> b -> DepGenM' (ta, tb)
instance TokenableTo [a] [DepGenM (Token a)] where
toToken = fmap ListToken . sequence
toTupleToken :: (TokenableTo ta a, TokenableTo tb b) => a -> b -> DepGenM (Token (ta, tb))
toTupleToken a b = TupleToken <$> toToken a <*> toToken b
mapDepGenM :: TokenableTo [a] v => (Token a -> DepGenM' b) -> v -> DepGenM' [b]
mapDepGenM :: TokenableTo [a] v => (Token a -> DepGenM (Token b)) -> v -> DepGenM (Token [b])
mapDepGenM f input = do
input' <- toToken input
genDependencyM $ \target -> do
@ -142,23 +133,23 @@ mapDepGenM_ f input = do
_ <- mapDepGenM (\x -> f x >> pure NoToken) input
pure ()
forDepGenM :: TokenableTo [a] v => v -> (Token a -> DepGenM' b) -> DepGenM' [b]
forDepGenM :: TokenableTo [a] v => v -> (Token a -> DepGenM (Token b)) -> DepGenM (Token [b])
forDepGenM = flip mapDepGenM
forDepGenM_ :: TokenableTo [a] v => v -> (Token a -> DepGenM ()) -> DepGenM ()
forDepGenM_ = flip mapDepGenM_
filterDepGenM' :: (TokenableTo [Bool] v, TokenableTo [a] u) => v -> u -> DepGenM' [a]
filterDepGenM' :: (TokenableTo [Bool] v, TokenableTo [a] u) => v -> u -> DepGenM (Token [a])
filterDepGenM' mask input = do
tup <- toTupleToken input mask
genDependency (makeDependency tup FilterComp)
filterDepGenM :: TokenableTo [a] v => (Token a -> DepGenM' Bool) -> v -> DepGenM' [a]
filterDepGenM :: TokenableTo [a] v => (Token a -> DepGenM (Token Bool)) -> v -> DepGenM (Token [a])
filterDepGenM f input = do
mask <- mapDepGenM f input
filterDepGenM' mask input
zipDepGenM :: (TokenableTo [a] v, TokenableTo [b] u) => v -> u -> DepGenM' [(a, b)]
zipDepGenM :: (TokenableTo [a] v, TokenableTo [b] u) => v -> u -> DepGenM (Token [(a, b)])
zipDepGenM a b = do
a' <- toToken a
b' <- toToken b
@ -206,79 +197,46 @@ unzipDepGenM t = do
b <- unzipSndDepGenM t'
pure (a, b)
appendStrings :: (TokenableTo String a, TokenableTo String b) => a -> b -> DepGenM' String
appendStrings :: (TokenableTo String a, TokenableTo String b) => a -> b -> DepGenM (Token String)
appendStrings a b = runFunction AppendStrings =<< TupleToken <$> toToken a <*> toToken b
concatStrings :: TokenableTo [String] a => a -> DepGenM' String
concatStrings :: TokenableTo [String] a => a -> DepGenM (Token String)
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 (Token Text)
appendTexts a b = runFunction AppendTexts =<< toTupleToken a b
concatTexts :: TokenableTo [Text] a => a -> DepGenM' Text
concatTexts :: TokenableTo [Text] a => a -> DepGenM (Token Text)
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 (Token FilePath)
joinPaths a b = runFunction JoinPaths =<< TupleToken <$> toToken a <*> toToken b
fileComponents :: TokenableTo FilePath a => a -> DepGenM' (String, String)
fileComponents :: TokenableTo FilePath a => a -> DepGenM (Token (String, String))
fileComponents a = runFunction FileComponents =<< toToken a
lowerString :: TokenableTo String a => a -> DepGenM' String
lowerString :: TokenableTo String a => a -> DepGenM (Token String)
lowerString a = runFunction LowerString =<< toToken a
elemOf :: (TokenableTo String a, TokenableTo [String] b) => a -> b -> DepGenM' Bool
elemOf :: (TokenableTo String a, TokenableTo [String] b) => a -> b -> DepGenM (Token Bool)
elemOf a b = runFunction ElemOf =<< toTupleToken a b
makeTemplate :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM' Template
makeTemplate :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM (Token Template)
makeTemplate a b = runFunction MakeTemplate =<< toTupleToken a b
applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGenM' Text
applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGenM (Token Text)
applyTemplate a b = runFunction ApplyTemplate =<< toTupleToken a b
toText :: TokenableTo String a => a -> DepGenM' Text
toText :: TokenableTo String a => a -> DepGenM (Token Text)
toText a = runFunction ToText =<< toToken a
convertImage :: (TokenableTo Image a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM' Image
convertImage :: (TokenableTo Image a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM (Token Image)
convertImage a b = runFunction ConvertImage =<< toTupleToken a b
runPandoc :: TokenableTo Text a => a -> DepGenM' Text
runPandoc :: TokenableTo Text a => a -> DepGenM (Token Text)
runPandoc a = runFunction RunPandoc =<< toToken a
listDirectory :: TokenableTo FilePath a => a -> DepGenM' [FilePath]
listDirectory a = runFunctionIO ListDirectory =<< toToken a
isDirectory :: TokenableTo FilePath a => a -> DepGenM' Bool
isDirectory a = runFunctionIO IsDirectory =<< toToken a
readTextFile :: TokenableTo FilePath a => a -> DepGenM' Text
readTextFile a = runFunctionIO ReadTextFile =<< toToken a
openImage :: TokenableTo FilePath a => a -> DepGenM' Image
openImage a = runFunctionIO OpenImage =<< toToken a
saveImage :: (TokenableTo Image a, TokenableTo FilePath b) => a -> b -> DepGenM ()
saveImage a b = runFunctionIO_ SaveImage =<< toTupleToken a b
saveTextFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM ()
saveTextFile a b = runFunctionIO_ SaveTextFile =<< toTupleToken a b
copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM ()
copyFile a b = runFunctionIO_ CopyFile =<< toTupleToken a b
copyFile' :: Token (FilePath, FilePath) -> DepGenM ()
copyFile' = runFunctionIO_ CopyFile
makeDir :: TokenableTo FilePath a => a -> DepGenM ()
makeDir a = runFunctionIO_ MakeDir =<< toToken a
hasExtension :: (TokenableTo [String] a, TokenableTo FilePath b) => a -> b -> DepGenM' Bool
hasExtension :: (TokenableTo [String] a, TokenableTo FilePath b) => a -> b -> DepGenM (Token Bool)
hasExtension exts filename = do
ext <- lowerString $ untupleSndDepGenM $ fileComponents filename
ext <- lowerString =<< untupleSndDepGenM =<< fileComponents filename
ext `elemOf` exts
copyTo :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM ()
copyTo path targetDir = do
pathToken <- toToken path
copyFile pathToken (joinPaths targetDir pathToken)

106
byg/src/FunctionIO.hs Normal file
View File

@ -0,0 +1,106 @@
module FunctionIO
( listDirectory
, isDirectory
, readTextFile
, openImage
, saveImage
, saveTextFile
, copyFile
, makeDir
) where
import Prelude hiding (String, FilePath)
import Types.FunctionIO
import Types.Values
import Types.Token (Token(..))
import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunctionIO, runFunctionIO_)
import Data.Text (Text)
import qualified Data.Text.IO as T
import qualified Codec.Picture as CP
import qualified System.Directory as SD
import Language.Haskell.TH.Syntax (Lift)
data ListDirectory = ListDirectory deriving (Show, Lift)
instance IsFunctionIO ListDirectory FilePath [FilePath] where
evalFunctionIO ListDirectory (StringWrapper s) =
map StringWrapper <$> SD.listDirectory s
functionIOTouchesFilesystem ListDirectory = False
listDirectory :: TokenableTo FilePath a => a -> DepGenM (Token [FilePath])
listDirectory a = runFunctionIO ListDirectory =<< toToken a
data IsDirectory = IsDirectory deriving (Show, Lift)
instance IsFunctionIO IsDirectory FilePath Bool where
evalFunctionIO IsDirectory (StringWrapper s) =
SD.doesDirectoryExist s
functionIOTouchesFilesystem IsDirectory = False
isDirectory :: TokenableTo FilePath a => a -> DepGenM (Token Bool)
isDirectory a = runFunctionIO IsDirectory =<< toToken a
data ReadTextFile = ReadTextFile deriving (Show, Lift)
instance IsFunctionIO ReadTextFile FilePath Text where
evalFunctionIO ReadTextFile (StringWrapper s) =
T.readFile s
functionIOTouchesFilesystem ReadTextFile = False
readTextFile :: TokenableTo FilePath a => a -> DepGenM (Token Text)
readTextFile a = runFunctionIO ReadTextFile =<< toToken a
data OpenImage = OpenImage deriving (Show, Lift)
instance IsFunctionIO OpenImage FilePath Image where
evalFunctionIO OpenImage (StringWrapper s) = do
imageOrig <- CP.readImage s
case imageOrig of
Left e -> error ("unexpected error: " ++ e)
Right image -> pure $ ImageWrapper $ CP.convertRGB8 image
functionIOTouchesFilesystem OpenImage = False
openImage :: TokenableTo FilePath a => a -> DepGenM (Token Image)
openImage a = runFunctionIO OpenImage =<< toToken a
data SaveImage = SaveImage deriving (Show, Lift)
instance IsFunctionIO SaveImage (Image, FilePath) () where
evalFunctionIO SaveImage (ImageWrapper image, StringWrapper s) =
CP.saveJpgImage 90 s $ CP.ImageRGB8 image
functionIOTouchesFilesystem SaveImage = True
saveImage :: (TokenableTo Image a, TokenableTo FilePath b) => a -> b -> DepGenM ()
saveImage a b = runFunctionIO_ SaveImage =<< toTupleToken a b
data SaveTextFile = SaveTextFile deriving (Show, Lift)
instance IsFunctionIO SaveTextFile (Text, FilePath) () where
evalFunctionIO SaveTextFile (t, StringWrapper s) =
T.writeFile s t
functionIOTouchesFilesystem SaveTextFile = True
saveTextFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM ()
saveTextFile a b = runFunctionIO_ SaveTextFile =<< toTupleToken a b
data CopyFile = CopyFile deriving (Show, Lift)
instance IsFunctionIO CopyFile (FilePath, FilePath) () where
evalFunctionIO CopyFile (StringWrapper source, StringWrapper target) =
SD.copyFile source target
functionIOTouchesFilesystem CopyFile = True
copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM ()
copyFile a b = runFunctionIO_ CopyFile =<< toTupleToken a b
data MakeDir = MakeDir deriving (Show, Lift)
instance IsFunctionIO MakeDir FilePath () where
evalFunctionIO MakeDir (StringWrapper s) =
SD.createDirectory s
functionIOTouchesFilesystem MakeDir = True
makeDir :: TokenableTo FilePath a => a -> DepGenM ()
makeDir a = runFunctionIO_ MakeDir =<< toToken a

6
byg/src/SiteGenerator.hs
View File

@ -4,9 +4,15 @@ import Prelude hiding (String, FilePath)
import Types
import DependencyGenerator
import FunctionIO
import Control.Monad (forM_)
copyTo :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM ()
copyTo path targetDir = do
pathToken <- toToken path
copyFile pathToken =<< joinPaths targetDir pathToken
handleRecipeDir :: Token FilePath -> Token Template -> Token FilePath -> Token FilePath -> DepGenM ()
handleRecipeDir outputDir htmlTemplate indexName dir = do
recipeDirOut <- joinPaths outputDir dir

67
byg/src/Types/FunctionIO.hs
View File

@ -1,78 +1,13 @@
{-# LANGUAGE FunctionalDependencies #-}
module Types.FunctionIO
( IsFunctionIO(..)
, ListDirectory(..)
, IsDirectory(..)
, ReadTextFile(..)
, OpenImage(..)
, SaveImage(..)
, SaveTextFile(..)
, CopyFile(..)
, MakeDir(..)
) where
import Prelude hiding (String, FilePath)
import Types.Values
import Types.Value (Valuable)
import Data.Text (Text)
import qualified Data.Text.IO as T
import qualified Codec.Picture as CP
import System.Directory (listDirectory, doesDirectoryExist, createDirectory, copyFile)
import Language.Haskell.TH.Syntax (Lift)
class (Show f, Lift f, Valuable a, Valuable b) => IsFunctionIO f a b | f -> a b where
evalFunctionIO :: f -> a -> IO b
functionIOTouchesFilesystem :: f -> Bool
data ListDirectory = ListDirectory deriving (Show, Lift)
instance IsFunctionIO ListDirectory FilePath [FilePath] where
evalFunctionIO ListDirectory (StringWrapper s) =
map StringWrapper <$> listDirectory s
functionIOTouchesFilesystem ListDirectory = False
data IsDirectory = IsDirectory deriving (Show, Lift)
instance IsFunctionIO IsDirectory FilePath Bool where
evalFunctionIO IsDirectory (StringWrapper s) =
doesDirectoryExist s
functionIOTouchesFilesystem IsDirectory = False
data ReadTextFile = ReadTextFile deriving (Show, Lift)
instance IsFunctionIO ReadTextFile FilePath Text where
evalFunctionIO ReadTextFile (StringWrapper s) =
T.readFile s
functionIOTouchesFilesystem ReadTextFile = False
data OpenImage = OpenImage deriving (Show, Lift)
instance IsFunctionIO OpenImage FilePath Image where
evalFunctionIO OpenImage (StringWrapper s) = do
imageOrig <- CP.readImage s
case imageOrig of
Left e -> error ("unexpected error: " ++ e)
Right image -> pure $ ImageWrapper $ CP.convertRGB8 image
functionIOTouchesFilesystem OpenImage = False
data SaveImage = SaveImage deriving (Show, Lift)
instance IsFunctionIO SaveImage (Image, FilePath) () where
evalFunctionIO SaveImage (ImageWrapper image, StringWrapper s) =
CP.saveJpgImage 90 s $ CP.ImageRGB8 image
functionIOTouchesFilesystem SaveImage = True
data SaveTextFile = SaveTextFile deriving (Show, Lift)
instance IsFunctionIO SaveTextFile (Text, FilePath) () where
evalFunctionIO SaveTextFile (t, StringWrapper s) =
T.writeFile s t
functionIOTouchesFilesystem SaveTextFile = True
data CopyFile = CopyFile deriving (Show, Lift)
instance IsFunctionIO CopyFile (FilePath, FilePath) () where
evalFunctionIO CopyFile (StringWrapper source, StringWrapper target) =
copyFile source target
functionIOTouchesFilesystem CopyFile = True
data MakeDir = MakeDir deriving (Show, Lift)
instance IsFunctionIO MakeDir FilePath () where
evalFunctionIO MakeDir (StringWrapper s) =
createDirectory s
functionIOTouchesFilesystem MakeDir = True