Freer-Simple Freer Monads Как унифицировать обработку исключений ввода-вывода с эффектом ошибки

Я использую freer-simple для написания очень простого DSL. Все, что он делает, это читает файл. У меня есть одно правило относительно имен файлов, они не могут содержать букву x. Любая попытка открыть файл с буквой x приведет к ошибке: Left (AppError "No Xs allowed in file name").

Как мне поймать ошибку ввода-вывода при чтении файла в fileSystemIOInterpreter и выдать ее как ошибку приложения? Т.е. Я пытаюсь преобразовать выбранные исключения ввода-вывода в AppErrors (см. ??????).

{- File System Lang -}

data FileSystem r where
  ReadFile :: Path a File -> FileSystem StrictReadResult

readFile :: Members '[FileSystem, Error AppError] effs => Path a File -> Eff effs StrictReadResult
readFile path = let
                  pthStr = toStr $ toFilePath path
                in
                  F.elem 'x' pthStr
                        ? throwError (AppError "No Xs allowed in file name")
                        $ send $ ReadFile path

{- Errors -}

newtype AppError = AppError String deriving Show

runAppError :: Eff (Error AppError ': r) a -> Eff r (Either AppError a)
runAppError = runError

{- File System IO Interpreter -}

fileSystemIOInterpreter :: forall effs a. (Members '[Error AppError] effs, LastMember IO effs) => Eff (FileSystem ': effs) a -> Eff effs a
fileSystemIOInterpreter = interpretM $ \case
                                          ReadFile path -> F.readFileUTF8 path
                                          -- ??????

-- this compiles: fileSystemIOInterpreter effs = throwError $ AppError "BLahh"

application :: Members '[FileSystem, Error AppError] effs => Path a File -> Eff effs StrictReadResult
application = readFile

ioApp :: Path a File -> IO (Either AppError StrictReadResult)
ioApp path = runM
              $ runAppError
              $ fileSystemIOInterpreter
              $ application path

-- running the app

demoPassApp = ioApp [absfile|C:\Vids\SystemDesign\VidList.md|]
>> Right (Right "Text content of VidList.md")

demoFailApp = ioApp [absfile|C:\Vids\SystemDesign\VidList.txt|]
>> Left (AppError "No Xs allowed in file name")

demoFailIOApp = ioApp [absfile|C:\Vids\SystemDesign\MissingFile.md|]
>> *** Exception: C:\Vids\SystemDesign\MissingFile.md: openBinaryFile: does not exist (No such file or directory)
-- I want to turn this into an AppError

haskell free-monad
person John Walker    schedule 01.09.2018    source источник

Ответы (2)


arrow_upward
3
arrow_downward

interpretM использует интерпретатор в IO (его первый аргумент имеет тип eff ~> m с m ~ IO здесь), так что это не позволяет вам генерировать AppErrors через ограничение Members '[Error AppError] effs.

Вместо этого вы можете использовать interpret с полным доступом к effs. Это будет примерно выглядеть так:

fileSystemIOInterpreter
  :: forall effs a
  .  (Members '[Error AppError] effs, LastMember IO effs)
  => Eff (FileSystem ': effs) a -> Eff effs a
fileSystemIOInterpreter = interpret $ \case
    ReadFile path -> do
        r <- sendM (try (F.readFileUTF8 path))
        case r of
            Left (e :: IOException) -> throwError (ioToAppErr e)
            Right f -> pure f

-- for some value of
ioToAppErr :: IOException -> AppError
person Li-yao Xia    schedule 01.09.2018

arrow_upward
1
arrow_downward

Вот полный рабочий пример:

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Data.String
import qualified Data.ByteString.Char8 as B
import Control.Exception
import Data.List
import Data.Text (Text, pack, unpack)
import Data.Text.IO
import Data.Text.Encoding (decodeUtf8)
import Control.Natural (type (~>))
import qualified  Control.Monad.Freer.Error as ER
import Control.Monad.Freer
  (
    Eff
  , LastMember
  , Member
  , Members
  , interpret
  , send
  , sendM
  , runM
  )

readFileUTF8 :: String -> IO Text
readFileUTF8 path = decodeUtf8 <$> B.readFile path

ioToAppErr :: IOException -> AppError
ioToAppErr ioe = AppError (displayException ioe)

newtype AppError = AppError String deriving Show

data FileSystem r where
  ReadFile :: FilePath -> FileSystem Text

readFile :: Members '[FileSystem, ER.Error AppError] effs => FilePath -> Eff effs Text
readFile fpath = if (elem 'x' fpath)
                     then (ER.throwError  (AppError "No Xs allowed in file name"))
                 else(send $ ReadFile fpath)

runAppError :: Eff (ER.Error AppError ': r) a -> Eff r (Either AppError a)
runAppError = ER.runError

fileSystemIOInterpreter
  :: (Members '[ER.Error AppError] effs, LastMember IO effs)
  => Eff (FileSystem ': effs) a -> Eff effs a
fileSystemIOInterpreter = interpret $ \case
    ReadFile path -> do
        r <- sendM (try (readFileUTF8 path))
        case r of
            Left (e :: IOException) -> ER.throwError (ioToAppErr e)
            Right f -> pure f

application :: Members '[FileSystem, ER.Error AppError] effs => FilePath -> Eff effs Text
application = Main.readFile

ioApp :: FilePath -> IO (Either AppError Text)
ioApp path = runM
              $ runAppError
              $ fileSystemIOInterpreter
              $ application path

main :: IO ()
main = do
  let pathX = "C:\\text.info"
  let pathNoX = "C:\\simple.t"
  let pathNoSuchAFile = "C:\\habrahabr.bib"
  result <- ioApp pathX
  Data.Text.IO.putStrLn $ pack (show result)

зависимости:

  • основание ›= 4,7 && ‹ 5
  • текст
  • свободный-простой
  • естественная трансформация
  • строка байтов
person Sergey Stretovich    schedule 07.07.2020