如何在Haskell中编写Monad高效追踪并预取i18n键？

我想编写一个Monad来追踪代码中使用的i18n键，目的是提前批量预取这些键对应的翻译值，避免代码执行时出现“N+1”查询问题。

我已经写了一部分代码（见下文），想请教：

• 如何为这个类型编写Monad实例？
• 这种实现思路是否可行？
• 还有其他实现方案吗？只要开发体验可控，我也接受类型层面追踪键的方案。

另外我想到一种“两阶段”执行的思路：

1. 第一阶段：返回两个结果——[I18nKey]（代码依赖的所有i18n键列表），以及[(I18nKey, I18nStr)] -> m Text（需要传入键值映射才能生成最终结果的未应用函数）。
2. 第二阶段：通过单次数据库查询把[I18nKey]转换成[(I18nKey, I18nStr)]，再将这个映射传入上述函数得到最终值。

请问如何用Haskell以符合人机工程学的方式实现这个逻辑？

现有代码（已实现Functor和Applicative） #

import UnliftIO.IORef
import Data.Text
import Control.Monad.Reader
import qualified Data.List as DL

type I18nKey = Text
type I18nStr = Text

data I18nEnv m a = I18nEnv
  { envI18nExpectedKeys :: [I18nKey]
  , envI18nVal :: ReaderT [(I18nKey, I18nStr)] m a
  }

instance (Functor m) => Functor (I18nEnv m) where
  {-# INLINE fmap #-}
  fmap f env = 
    env{envI18nVal=fmap f (envI18nVal env)}

instance (Applicative m) => Applicative (I18nEnv m) where
  {-# INLINE pure #-}
  pure x = 
    I18nEnv { envI18nExpectedKeys = [], envI18nVal = pure x }

  {-# INLINE (<*>) #-}
  (<*>) fn a = I18nEnv
    { envI18nExpectedKeys=(envI18nExpectedKeys fn <> envI18nExpectedKeys a)
    , envI18nVal=(envI18nVal fn) <*> (envI18nVal a)
    }

尝试的实用代码（无法编译） #

import Lucid
import qualified Data.HashMap.Strict as HM
import UnlifIO
import Data.Set (Set)

type I18nKey = Text -- 示例：en.user_greeting
type I18NInterpolation = Text -- 示例："Hello {{ username }}"
type I18nReplacements = [(Text, Text)] -- 示例：[("username", "john doe"), ("email", "johndoe@gmail.com")]

data HtmlCtx = HtmlCtx 
  { ctxI18nKeysetRef :: !(IORef (Set I18nKey))
  } deriving (Eq, Show)
$(makeLensesWith abbreviatedFields ''HtmlCtx)


translate :: I18nKey -> I18nReplacements -> HM.HashMap I18nKey I18NInterpolation -> Text
translate = undefined

newtype UnappliedI18n a = UnappliedI18n { rawUnappliedI18n :: HM.HashMap I18nKey I18NInterpolation -> a } deriving (Generic, Functor, Applicative, Monad, Semigroup, Monoid)

newtype I18nHtml a 
  = I18nHtml { rawI18nHtml :: HtmlT (ReaderT HtmlCtx IO) (UnappliedI18n a) }
    deriving (Generic, Functor, Applicative, Monad, MonadReader HtmlCtx)

解决方案 #

1. 为I18nEnv m编写Monad实例 #

要实现Monad实例，核心是处理>>=操作时的键合并：当绑定一个返回I18nEnv m b的函数时，需要把当前I18nEnv m a的键，和函数返回的I18nEnv m b的键合并。

实现代码如下：

instance (Monad m) => Monad (I18nEnv m) where
  {-# INLINE (>>=) #-}
  env >>= f = I18nEnv
    { envI18nExpectedKeys = envI18nExpectedKeys env <> envI18nExpectedKeys nextEnv
    , envI18nVal = envI18nVal env >>= \x -> envI18nVal nextEnv
    }
    where
      -- 仅收集键，不需要实际映射值，用undefined占位
      nextEnv = f <$> runReaderT (envI18nVal env) undefined

  {-# INLINE return #-}
  return = pure

可行性说明：这种思路完全可行。I18nEnv本质是把“收集键”和“延迟计算”结合起来，第一阶段收集所有需要的键，第二阶段传入实际的翻译映射执行计算。

2. 优化：用Set去重键 #

当前代码用[I18nKey]会导致重复键被多次收集，建议换成Set I18nKey避免冗余查询，同时用HashMap替代列表提升查询效率：

import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.HashMap.Strict as HM

data I18nEnv m a = I18nEnv
  { envI18nExpectedKeys :: Set I18nKey
  , envI18nVal :: ReaderT (HM.HashMap I18nKey I18nStr) m a
  }

instance (Applicative m) => Applicative (I18nEnv m) where
  pure x = I18nEnv { envI18nExpectedKeys = S.empty, envI18nVal = pure x }
  (<*>) fn a = I18nEnv
    { envI18nExpectedKeys = S.union (envI18nExpectedKeys fn) (envI18nExpectedKeys a)
    , envI18nVal = envI18nVal fn <*> envI18nVal a
    }

instance (Monad m) => Monad (I18nEnv m) where
  env >>= f = I18nEnv
    { envI18nExpectedKeys = S.union (envI18nExpectedKeys env) (envI18nExpectedKeys nextEnv)
    , envI18nVal = envI18nVal env >>= \x -> envI18nVal nextEnv
    }
    where
      nextEnv = f <$> runReaderT (envI18nVal env) HM.empty

3. 两阶段执行的人机工程学实现 #

可以把两阶段逻辑封装成两个函数，让使用流程更清晰：

-- 第一阶段：收集所有需要的i18n键
collectKeys :: I18nEnv m a -> Set I18nKey
collectKeys = envI18nExpectedKeys

-- 第二阶段：传入翻译映射，执行计算得到最终结果
runWithTranslations :: HM.HashMap I18nKey I18nStr -> I18nEnv m a -> m a
runWithTranslations translations env = runReaderT (envI18nVal env) translations

-- 封装helper函数，简化i18n键的收集与延迟计算
i18n :: I18nKey -> (I18nStr -> a) -> I18nEnv m a
i18n key f = I18nEnv
  { envI18nExpectedKeys = S.singleton key
  , envI18nVal = f <$> asks (HM.lookup key >>= maybe (pure key) pure)
  }

-- 使用示例
getGreeting :: I18nEnv IO Text
getGreeting = do
  username <- pure "Alice"
  greetingTemplate <- i18n "en.user.greeting" id
  pure $ replaceVars greetingTemplate [("username", username)]

-- 模拟变量替换
replaceVars :: Text -> [(Text, Text)] -> Text
replaceVars template vars = foldr (\(k,v) t -> replace ("{{ " <> k <> " }}") v t) template vars

-- 模拟数据库批量查询
fetchTranslationsFromDB :: Set I18nKey -> IO (HM.HashMap I18nKey I18nStr)
fetchTranslationsFromDB keys = pure $ HM.fromList [(k, "Hello, {{ username }}") | k <- S.toList keys]

-- 执行流程
main :: IO ()
main = do
  let keys = collectKeys getGreeting
  translations <- fetchTranslationsFromDB keys
  greeting <- runWithTranslations translations getGreeting
  print greeting

4. 修正无法编译的I18nHtml代码 #

原代码存在拼写错误和缺失导入的问题，修正后代码如下：

import Lucid
import qualified Data.HashMap.Strict as HM
import UnliftIO
import Data.Set (Set)
import Control.Lens.TH
import GHC.Generics (Generic)
import qualified Data.Set as S

type I18nKey = Text -- 示例：en.user_greeting
type I18NInterpolation = Text -- 示例："Hello {{ username }}"
type I18nReplacements = [(Text, Text)] -- 示例：[("username", "john doe"), ("email", "johndoe@gmail.com")]

data HtmlCtx = HtmlCtx 
  { ctxI18nKeysetRef :: !(IORef (Set I18nKey))
  } deriving (Eq, Show)
$(makeLensesWith abbreviatedFields ''HtmlCtx)

translate :: I18nKey -> I18nReplacements -> HM.HashMap I18nKey I18NInterpolation -> Text
translate key replacements translations =
  case HM.lookup key translations of
    Just template -> foldr (\(k,v) -> replace ("{{ " <> k <> " }}") v) template replacements
    Nothing -> key

newtype UnappliedI18n a = UnappliedI18n { rawUnappliedI18n :: HM.HashMap I18nKey I18NInterpolation -> a } 
  deriving (Generic, Functor, Applicative, Monad, Semigroup, Monoid)

newtype I18nHtml a 
  = I18nHtml { rawI18nHtml :: HtmlT (ReaderT HtmlCtx IO) (UnappliedI18n a) }
    deriving (Generic, Functor, Applicative, Monad, MonadReader HtmlCtx)

-- 封装Html场景下的i18n键收集逻辑
i18nHtml :: I18nKey -> I18nReplacements -> I18nHtml (Html ())
i18nHtml key replacements = do
  HtmlCtx ref <- ask
  liftIO $ modifyIORef' ref (S.insert key)
  pure $ UnappliedI18n $ \trans -> toHtml $ translate key replacements trans

-- 使用示例
userProfileHtml :: Text -> I18nHtml (Html ())
userProfileHtml username = do
  h1_ =<< i18nHtml "en.profile.title" []
  p_ =<< i18nHtml "en.profile.greeting" [("username", username)]

-- 渲染流程
renderUserProfile :: Text -> IO (Html ())
renderUserProfile username = do
  ref <- newIORef S.empty
  unapplied <- runReaderT (runHtmlT $ rawI18nHtml $ userProfileHtml username) (HtmlCtx ref)
  keys <- readIORef ref
  trans <- fetchTranslationsFromDB keys
  pure $ rawUnappliedI18n unapplied trans

5. 类型层面追踪键的方案（进阶） #

如果想在编译时就追踪所有依赖的i18n键，可以用GHC的类型级特性实现：

import GHC.TypeLits
import Data.Kind (Type)
import qualified Data.HashMap.Strict as HM

-- 用类型级列表存储i18n键
data I18n (keys :: [Symbol]) m a = I18n
  { runI18n :: ReaderT (HM.HashMap Text I18nStr) m a
  }

-- 封装函数，将键添加到类型中
i18nType :: KnownSymbol key => Proxy key -> (I18nStr -> a) -> I18n '[key] m a
i18nType proxy f = I18n $ f <$> asks (HM.lookup (symbolVal proxy) >>= maybe (pure $ symbolVal proxy) pure)

-- 合并两个I18n实例的键列表
mergeI18n :: I18n ks1 m a -> I18n ks2 m b -> I18n (ks1 ++ ks2) m (a, b)
mergeI18n (I18n a) (I18n b) = I18n $ (,) <$> a <*> b

优点：编译时就能明确所有依赖的键，避免运行时收集开销；缺点：类型会随键数量增多变得复杂，适合键数量较少的场景。

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