Put more types into IsFunctionIO

This commit is contained in:
Niels G. W. Serup 2024-10-06 13:19:06 +02:00
parent b84e45ed8f
commit 21d5366fea
No known key found for this signature in database
GPG Key ID: 38EEEBCE67324F19
3 changed files with 18 additions and 14 deletions

View File

@ -101,10 +101,10 @@ inject x = genDependency (makeDependency NoToken (Inject (toValue x)))
runFunction :: Function -> Token a -> DepGenM' b runFunction :: Function -> Token a -> DepGenM' b
runFunction f input = genDependency (makeDependency input (Function f)) runFunction f input = genDependency (makeDependency input (Function f))
runFunctionIO :: IsFunctionIO f => f -> Token a -> DepGenM' b runFunctionIO :: IsFunctionIO f a b => f -> Token a -> DepGenM' b
runFunctionIO f input = genDependency (makeDependency input (FunctionIO f)) runFunctionIO f input = genDependency (makeDependency input (FunctionIO f))
runFunctionIO_ :: IsFunctionIO f => f -> Token a -> DepGenM () runFunctionIO_ :: IsFunctionIO f a b => f -> Token a -> DepGenM ()
runFunctionIO_ f input = tellDep $ makeDependency input (FunctionIO f) NoToken runFunctionIO_ f input = tellDep $ makeDependency input (FunctionIO f) NoToken
class TokenableTo t s | s -> t where class TokenableTo t s | s -> t where

View File

@ -21,7 +21,7 @@ import Language.Haskell.TH.Syntax (Lift)
data Action where data Action where
Function :: Function -> Action Function :: Function -> Action
FunctionIO :: IsFunctionIO f => f -> Action FunctionIO :: IsFunctionIO f a b => f -> Action
Inject :: Value -> Action Inject :: Value -> Action
FilterComp :: Action FilterComp :: Action
UntupleFst :: Action UntupleFst :: Action

View File

@ -1,3 +1,4 @@
{-# LANGUAGE FunctionalDependencies #-}
module Types.FunctionIO module Types.FunctionIO
( IsFunctionIO(..) ( IsFunctionIO(..)
, ListDirectory(..) , ListDirectory(..)
@ -10,20 +11,23 @@ module Types.FunctionIO
, MakeDir(..) , MakeDir(..)
) where ) where
import Types.Values import Prelude hiding (String, FilePath)
import Types.Value (Value(..), toValue, makeImage)
import Types.Values
import Types.Value (Value(..), Valuable(..), makeImage)
import Data.Text (Text)
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import qualified Codec.Picture as CP import qualified Codec.Picture as CP
import System.Directory (listDirectory, doesDirectoryExist, createDirectory, copyFile) import System.Directory (listDirectory, doesDirectoryExist, createDirectory, copyFile)
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
class (Show f, Lift f) => IsFunctionIO f where class (Show f, Lift f, Valuable a, Valuable b) => IsFunctionIO f a b | f -> a b where
evalFunctionIO :: f -> Value -> IO Value evalFunctionIO :: f -> Value -> IO Value
functionIOTouchesFilesystem :: f -> Bool functionIOTouchesFilesystem :: f -> Bool
data ListDirectory = ListDirectory deriving (Show, Lift) data ListDirectory = ListDirectory deriving (Show, Lift)
instance IsFunctionIO ListDirectory where instance IsFunctionIO ListDirectory FilePath [FilePath] where
evalFunctionIO ListDirectory = \case evalFunctionIO ListDirectory = \case
String (StringWrapper s) -> String (StringWrapper s) ->
(List . map (toValue . StringWrapper)) <$> listDirectory s (List . map (toValue . StringWrapper)) <$> listDirectory s
@ -31,7 +35,7 @@ instance IsFunctionIO ListDirectory where
functionIOTouchesFilesystem ListDirectory = False functionIOTouchesFilesystem ListDirectory = False
data IsDirectory = IsDirectory deriving (Show, Lift) data IsDirectory = IsDirectory deriving (Show, Lift)
instance IsFunctionIO IsDirectory where instance IsFunctionIO IsDirectory FilePath Bool where
evalFunctionIO IsDirectory = \case evalFunctionIO IsDirectory = \case
String (StringWrapper s) -> String (StringWrapper s) ->
Bool <$> doesDirectoryExist s Bool <$> doesDirectoryExist s
@ -39,7 +43,7 @@ instance IsFunctionIO IsDirectory where
functionIOTouchesFilesystem IsDirectory = False functionIOTouchesFilesystem IsDirectory = False
data ReadTextFile = ReadTextFile deriving (Show, Lift) data ReadTextFile = ReadTextFile deriving (Show, Lift)
instance IsFunctionIO ReadTextFile where instance IsFunctionIO ReadTextFile FilePath Text where
evalFunctionIO ReadTextFile = \case evalFunctionIO ReadTextFile = \case
String (StringWrapper s) -> String (StringWrapper s) ->
Text <$> T.readFile s Text <$> T.readFile s
@ -47,7 +51,7 @@ instance IsFunctionIO ReadTextFile where
functionIOTouchesFilesystem ReadTextFile = False functionIOTouchesFilesystem ReadTextFile = False
data OpenImage = OpenImage deriving (Show, Lift) data OpenImage = OpenImage deriving (Show, Lift)
instance IsFunctionIO OpenImage where instance IsFunctionIO OpenImage FilePath Image where
evalFunctionIO OpenImage = \case evalFunctionIO OpenImage = \case
String (StringWrapper s) -> do String (StringWrapper s) -> do
imageOrig <- CP.readImage s imageOrig <- CP.readImage s
@ -58,7 +62,7 @@ instance IsFunctionIO OpenImage where
functionIOTouchesFilesystem OpenImage = False functionIOTouchesFilesystem OpenImage = False
data SaveImage = SaveImage deriving (Show, Lift) data SaveImage = SaveImage deriving (Show, Lift)
instance IsFunctionIO SaveImage where instance IsFunctionIO SaveImage (Image, FilePath) () where
evalFunctionIO SaveImage = \case evalFunctionIO SaveImage = \case
Tuple (Image (ImageWrapper image), String (StringWrapper s)) -> do Tuple (Image (ImageWrapper image), String (StringWrapper s)) -> do
CP.saveJpgImage 90 s $ CP.ImageRGB8 image CP.saveJpgImage 90 s $ CP.ImageRGB8 image
@ -67,7 +71,7 @@ instance IsFunctionIO SaveImage where
functionIOTouchesFilesystem SaveImage = True functionIOTouchesFilesystem SaveImage = True
data SaveTextFile = SaveTextFile deriving (Show, Lift) data SaveTextFile = SaveTextFile deriving (Show, Lift)
instance IsFunctionIO SaveTextFile where instance IsFunctionIO SaveTextFile (Text, FilePath) () where
evalFunctionIO SaveTextFile = \case evalFunctionIO SaveTextFile = \case
Tuple (Text t, String (StringWrapper s)) -> do Tuple (Text t, String (StringWrapper s)) -> do
T.writeFile s t T.writeFile s t
@ -76,7 +80,7 @@ instance IsFunctionIO SaveTextFile where
functionIOTouchesFilesystem SaveTextFile = True functionIOTouchesFilesystem SaveTextFile = True
data CopyFile = CopyFile deriving (Show, Lift) data CopyFile = CopyFile deriving (Show, Lift)
instance IsFunctionIO CopyFile where instance IsFunctionIO CopyFile (FilePath, FilePath) () where
evalFunctionIO CopyFile = \case evalFunctionIO CopyFile = \case
Tuple (String (StringWrapper source), String (StringWrapper target)) -> do Tuple (String (StringWrapper source), String (StringWrapper target)) -> do
copyFile source target copyFile source target
@ -85,7 +89,7 @@ instance IsFunctionIO CopyFile where
functionIOTouchesFilesystem CopyFile = True functionIOTouchesFilesystem CopyFile = True
data MakeDir = MakeDir deriving (Show, Lift) data MakeDir = MakeDir deriving (Show, Lift)
instance IsFunctionIO MakeDir where instance IsFunctionIO MakeDir FilePath () where
evalFunctionIO MakeDir = \case evalFunctionIO MakeDir = \case
String (StringWrapper s) -> do String (StringWrapper s) -> do
createDirectory s createDirectory s