如何将含error的Haskell代码重构为使用ExceptT？

原有代码通过ordering函数解析字符串列表生成Map String Order，使用error处理解析错误。尝试将错误封装到ExceptT中时，出现类型不匹配：parseOrder返回(String, ExceptT () IO Order)类型，但Map.fromList需要(String, Order)类型的键值对。需保留where子句结构，求正确重构方式。

原有代码 #

import Data.Map (Map)
import qualified Data.Map as Map
data Order = LeftToRight | RightToLeft
  deriving Show

ordering :: [String] -> Map String Order
ordering ls = Map.fromList pairs -- TODO: refactor to a monad
  where
  pairs = map parseOrder ls
  parseOrder s =
    case words s of
      [v, o] -> (v, o')
        where
          o' = case o of
            "l2r" -> LeftToRight
            "r2l" -> RightToLeft
            _     -> error $ "parse error in ordering:" ++ s
      _ -> error $ "parse error in ordering: " ++ s

尝试的重构代码 #

import Data.Map (Map)
import qualified Data.Map as Map

import qualified System.Exit as Exit
import Control.Monad.Trans.Except
import Control.Monad.IO.Class (liftIO)

die :: String -> ExceptT () IO a
die msg = liftIO $ Exit.die ("\ESC[31mERROR: \ESC[0m" ++ msg)

data Order = LeftToRight | RightToLeft
  deriving Show

ordering' :: [String] -> ExceptT () IO (Map String Order)
ordering' ls = return (Map.fromList pairs)
  where
  pairs = map parseOrder ls
  parseOrder s =
    case words s of
      [v, o] -> (v, o')
        where
          o' = case o of
            "l2r" -> LeftToRight
            "r2l" -> RightToLeft
            _     -> die $ "parse error in ordering:" ++ s
      _ -> die $ "parse error in ordering: " ++ s


main :: IO ()
main = do
  let x = ["a l2r", "b r2l", "b c r2l"]
  p <- runExceptT $ ordering' x
  putStrLn (show p)

报错信息 #

eg.hs:30:37: error: [GHC-83865]
    • Couldn't match type ‘ExceptT () IO Order’ with ‘Order’
      Expected: [(String, Order)]
        Actual: [(String, ExceptT () IO Order)]
    • In the first argument of ‘Map.fromList’, namely ‘pairs’
      In the first argument of ‘return’, namely ‘(Map.fromList pairs)’
      In the expression: return (Map.fromList pairs)
   |
30 | ordering' ls = return (Map.fromList pairs)
   |                                     ^^^^^

解决方案 #

问题核心在于：parseOrder现在返回的是带有ExceptT上下文的值，不能直接用map生成纯键值对列表。需要在ExceptT monad中遍历列表，执行每个解析动作，收集结果后再转换为Map。

修改要点：

1. 调整parseOrder的返回类型为ExceptT () IO (String, Order)，让整个元组都处于monad上下文中；
2. 使用mapM（而非map）遍历列表，将每个parseOrder的执行结果收集为ExceptT () IO [(String, Order)]；
3. 对收集到的列表应用Map.fromList，最终返回ExceptT () IO (Map String Order)。

正确重构代码 #

import Data.Map (Map)
import qualified Data.Map as Map

import qualified System.Exit as Exit
import Control.Monad.Trans.Except
import Control.Monad.IO.Class (liftIO)

die :: String -> ExceptT () IO a
die msg = liftIO $ Exit.die ("\ESC[31mERROR: \ESC[0m" ++ msg)

data Order = LeftToRight | RightToLeft
  deriving Show

ordering' :: [String] -> ExceptT () IO (Map String Order)
ordering' ls = Map.fromList <$> mapM parseOrder ls
  where
  parseOrder s =
    case words s of
      [v, o] -> case o of
        "l2r" -> return (v, LeftToRight)
        "r2l" -> return (v, RightToLeft)
        _     -> die $ "parse error in ordering:" ++ s
      _ -> die $ "parse error in ordering: " ++ s


main :: IO ()
main = do
  let x = ["a l2r", "b r2l", "b c r2l"]
  p <- runExceptT $ ordering' x
  putStrLn (show p)

代码解释 #

• parseOrder现在直接返回ExceptT () IO (String, Order)：解析成功时用return包裹键值对，失败时调用die抛出错误；
• mapM parseOrder ls会遍历列表，依次执行每个解析动作，若中途遇到错误则立即终止并返回错误；
• Map.fromList <$> ...使用fmap将纯函数Map.fromList应用到monad上下文内的列表上，最终得到包含Map的ExceptT结果；
• 完全保留了原有的where子句结构，符合需求。

内容的提问来源于stack exchange，提问作者sdpoll