Have instance declarations be independent of Value

This commit is contained in:
Niels G. W. Serup 2024-10-06 13:25:09 +02:00
parent 21d5366fea
commit 381ecd5f03
No known key found for this signature in database
GPG Key ID: 38EEEBCE67324F19
2 changed files with 23 additions and 43 deletions

View File

@ -4,7 +4,7 @@ module DependencyRunner
, runDepRunMIO , runDepRunMIO
) where ) where
import Types (Value(..), fromValue, evalFunctionIO) import Types (Value(..), Valuable(..), evalFunctionIO)
import Types.Dependency import Types.Dependency
import Evaluation.Function import Evaluation.Function
@ -84,7 +84,7 @@ runAction action input = case action of
Function f -> Function f ->
pure $ evalFunction f input pure $ evalFunction f input
FunctionIO f -> FunctionIO f ->
liftIO $ evalFunctionIO f input liftIO (toValue <$> evalFunctionIO f (fromValue input))
Inject v -> Inject v ->
pure v pure v
FilterComp -> FilterComp ->

View File

@ -14,7 +14,7 @@ module Types.FunctionIO
import Prelude hiding (String, FilePath) import Prelude hiding (String, FilePath)
import Types.Values import Types.Values
import Types.Value (Value(..), Valuable(..), makeImage) import Types.Value (Valuable)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
@ -23,76 +23,56 @@ import System.Directory (listDirectory, doesDirectoryExist, createDirectory, cop
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
class (Show f, Lift f, Valuable a, Valuable b) => IsFunctionIO f a b | f -> a b 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 -> a -> IO b
functionIOTouchesFilesystem :: f -> Bool functionIOTouchesFilesystem :: f -> Bool
data ListDirectory = ListDirectory deriving (Show, Lift) data ListDirectory = ListDirectory deriving (Show, Lift)
instance IsFunctionIO ListDirectory FilePath [FilePath] where instance IsFunctionIO ListDirectory FilePath [FilePath] where
evalFunctionIO ListDirectory = \case evalFunctionIO ListDirectory (StringWrapper s) =
String (StringWrapper s) -> map StringWrapper <$> listDirectory s
(List . map (toValue . StringWrapper)) <$> listDirectory s
_ -> error "unexpected"
functionIOTouchesFilesystem ListDirectory = False functionIOTouchesFilesystem ListDirectory = False
data IsDirectory = IsDirectory deriving (Show, Lift) data IsDirectory = IsDirectory deriving (Show, Lift)
instance IsFunctionIO IsDirectory FilePath Bool where instance IsFunctionIO IsDirectory FilePath Bool where
evalFunctionIO IsDirectory = \case evalFunctionIO IsDirectory (StringWrapper s) =
String (StringWrapper s) -> doesDirectoryExist s
Bool <$> doesDirectoryExist s
_ -> error "unexpected"
functionIOTouchesFilesystem IsDirectory = False functionIOTouchesFilesystem IsDirectory = False
data ReadTextFile = ReadTextFile deriving (Show, Lift) data ReadTextFile = ReadTextFile deriving (Show, Lift)
instance IsFunctionIO ReadTextFile FilePath Text where instance IsFunctionIO ReadTextFile FilePath Text where
evalFunctionIO ReadTextFile = \case evalFunctionIO ReadTextFile (StringWrapper s) =
String (StringWrapper s) -> T.readFile s
Text <$> T.readFile s
_ -> error "unexpected"
functionIOTouchesFilesystem ReadTextFile = False functionIOTouchesFilesystem ReadTextFile = False
data OpenImage = OpenImage deriving (Show, Lift) data OpenImage = OpenImage deriving (Show, Lift)
instance IsFunctionIO OpenImage FilePath Image where instance IsFunctionIO OpenImage FilePath Image where
evalFunctionIO OpenImage = \case evalFunctionIO OpenImage (StringWrapper s) = do
String (StringWrapper s) -> do imageOrig <- CP.readImage s
imageOrig <- CP.readImage s case imageOrig of
case imageOrig of Left e -> error ("unexpected error: " ++ e)
Left e -> error ("unexpected error: " ++ e) Right image -> pure $ ImageWrapper $ CP.convertRGB8 image
Right image -> pure $ makeImage $ CP.convertRGB8 image
_ -> error "unexpected"
functionIOTouchesFilesystem OpenImage = False functionIOTouchesFilesystem OpenImage = False
data SaveImage = SaveImage deriving (Show, Lift) data SaveImage = SaveImage deriving (Show, Lift)
instance IsFunctionIO SaveImage (Image, FilePath) () where instance IsFunctionIO SaveImage (Image, FilePath) () where
evalFunctionIO SaveImage = \case evalFunctionIO SaveImage (ImageWrapper image, StringWrapper s) =
Tuple (Image (ImageWrapper image), String (StringWrapper s)) -> do CP.saveJpgImage 90 s $ CP.ImageRGB8 image
CP.saveJpgImage 90 s $ CP.ImageRGB8 image
pure Empty
_ -> error "unexpected"
functionIOTouchesFilesystem SaveImage = True functionIOTouchesFilesystem SaveImage = True
data SaveTextFile = SaveTextFile deriving (Show, Lift) data SaveTextFile = SaveTextFile deriving (Show, Lift)
instance IsFunctionIO SaveTextFile (Text, FilePath) () where instance IsFunctionIO SaveTextFile (Text, FilePath) () where
evalFunctionIO SaveTextFile = \case evalFunctionIO SaveTextFile (t, StringWrapper s) =
Tuple (Text t, String (StringWrapper s)) -> do T.writeFile s t
T.writeFile s t
pure Empty
_ -> error "unexpected"
functionIOTouchesFilesystem SaveTextFile = True functionIOTouchesFilesystem SaveTextFile = True
data CopyFile = CopyFile deriving (Show, Lift) data CopyFile = CopyFile deriving (Show, Lift)
instance IsFunctionIO CopyFile (FilePath, FilePath) () where instance IsFunctionIO CopyFile (FilePath, FilePath) () where
evalFunctionIO CopyFile = \case evalFunctionIO CopyFile (StringWrapper source, StringWrapper target) =
Tuple (String (StringWrapper source), String (StringWrapper target)) -> do copyFile source target
copyFile source target
pure Empty
_ -> error "unexpected"
functionIOTouchesFilesystem CopyFile = True functionIOTouchesFilesystem CopyFile = True
data MakeDir = MakeDir deriving (Show, Lift) data MakeDir = MakeDir deriving (Show, Lift)
instance IsFunctionIO MakeDir FilePath () where instance IsFunctionIO MakeDir FilePath () where
evalFunctionIO MakeDir = \case evalFunctionIO MakeDir (StringWrapper s) =
String (StringWrapper s) -> do createDirectory s
createDirectory s
pure Empty
_ -> error "unexpected"
functionIOTouchesFilesystem MakeDir = True functionIOTouchesFilesystem MakeDir = True