haskell - 使用类型类为使用 Acid-State 时提供替代实现

Question

我使用 scotty 和 acid state 编写了一个 Web 应用程序，现在我想使用类型类来为我的应用程序的测试功能提供替代实现。我了解了它的一般概念，并且能够将它应用到如此简单的示例中，但由于我使用的是酸性状态，因此涉及到很多类型类和模板 haskell，我还不太适应。

所以我有这些针对不同功能的直接类

class Logging m where
  log :: T.Text -> m ()

class Server m where
  body :: m B.ByteString
  respond :: T.Text -> m ()
  setHeader :: T.Text -> T.Text -> m ()

class Db m where
  dbQuery :: (MethodState event ~ Database,QueryEvent event) => event -> m (EventResult event)
  dbUpdate :: (MethodState event ~ Database,UpdateEvent event) => event -> m (EventResult event)

而且我还为我的“生产”monad 提供了它们的实例。

但是当涉及到数据库功能时，我无法按照自己的意愿工作。

类看起来是这样的

class Db m where
  dbQuery :: (MethodState event ~ Database,QueryEvent event) => event -> m (EventResult event)
  dbUpdate :: (MethodState event ~ Database,UpdateEvent event) => event -> m (EventResult event)

生产 monad 的实例工作正常，因为它只将事件传递给 acid state 的更新和查询函数，但对于测试 monad，我希望有这样的东西: 实例 Db 测试位置 dbQuery (GetVersion) = 使用 (testDb.clientVersion) dbQuery (GetUser name) = preuse (testDb.users.ix name) dbUpdate(PutUser name user) = users %= M.insert name user ...这样我就可以匹配 GetVersion、GetUser 等(由模板 haskell 函数 makeAcidic ... 生成)并指定在测试环境中应如何处理它们。

但是我得到了错误:

Could not deduce: event ~ GetVersion
from the context: (MethodState event ~ Database, QueryEvent event)
  bound by the type signature for:
              dbQuery :: (MethodState event ~ Database, QueryEvent event) =>
                        event -> Test (EventResult event)
  at Main.hs:88:3-9
‘event’ is a rigid type variable bound by
  the type signature for:
    dbQuery :: forall event.
                (MethodState event ~ Database, QueryEvent event) =>
                event -> Test (EventResult event)
  at Main.hs:88:3
• In the pattern: GetVersion
In an equation for ‘dbQuery’:
    dbQuery (GetVersion) = use (testDb . clientVersion)
In the instance declaration for ‘Db Test’
• Relevant bindings include
  dbQuery :: event -> Test (EventResult event)
    (bound at Main.hs:88:3)

我想那是因为 GetVersion、GetUser 等都有自己不同的类型。那么有没有办法做到这一点？

---

合并建议

我尝试了 Peter Amidon 提出的建议，但遗憾的是它仍然没有编译这里是我的测试代码

{-# LANGUAGE GADTs #-}               -- For type equality
{-# LANGUAGE TypeOperators #-}       -- For type equality
{-# LANGUAGE TypeFamilies #-}        -- For EventResult
{-# LANGUAGE ScopedTypeVariables #-} -- For writing castWithWitness
{-# LANGUAGE TypeApplications #-}    -- For convenience
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

import Control.Lens
import Data.Acid
import qualified Data.Text.Lazy as T
import Types
import Data.Typeable

main = return ()

getUser :: Username -> Query Database (Maybe User)
getUser name = preview (users . ix name)

getVersion :: Query Database T.Text
getVersion = view clientVersion

$(makeAcidic ''Database ['getUser,'getVersion])

castWithWitness :: forall b a. (Typeable a, Typeable b)
                => a -> Maybe (b :~: a, b)
castWithWitness x = case eqT @a @b of
                      Nothing -> Nothing
                      Just Refl -> Just (Refl, x)

exampleFunction :: forall a. QueryEvent a => a -> EventResult a
exampleFunction (castWithWitness @GetVersion -> (Just Refl, Just GetVersion)) = "1.0"
exampleFunction (castWithWitness @GetUser -> (Just Refl, Just (GetUser n))) = Nothing

这里是错误

Main.hs:124:49: error:
    • Couldn't match expected type ‘Maybe
                                      (GetVersion :~: a, GetVersion)’
                  with actual type ‘(Maybe (t1 :~: t2), t0)’
    • In the pattern: (Just Refl, Just GetVersion)
      In the pattern:
        castWithWitness @GetVersion -> (Just Refl, Just GetVersion)
      In an equation for ‘exampleFunction’:
          exampleFunction
            (castWithWitness @GetVersion -> (Just Refl, Just GetVersion))
            = "1.0"
    • Relevant bindings include
        exampleFunction :: a -> EventResult a (bound at Main.hs:124:1)

Main.hs:124:61: error:
    • Couldn't match expected type ‘t0’
                  with actual type ‘Maybe GetVersion’
        ‘t0’ is untouchable
          inside the constraints: t2 ~ t1
          bound by a pattern with constructor:
                    Refl :: forall k (a :: k). a :~: a,
                  in an equation for ‘exampleFunction’
          at Main.hs:124:55-58
    • In the pattern: Just GetVersion
      In the pattern: (Just Refl, Just GetVersion)
      In the pattern:
        castWithWitness @GetVersion -> (Just Refl, Just GetVersion)

Main.hs:125:46: error:
    • Couldn't match expected type ‘Maybe (GetUser :~: a, GetUser)’
                  with actual type ‘(Maybe (t4 :~: t5), t3)’
    • In the pattern: (Just Refl, Just (GetUser n))
      In the pattern:
        castWithWitness @GetUser -> (Just Refl, Just (GetUser n))
      In an equation for ‘exampleFunction’:
          exampleFunction
            (castWithWitness @GetUser -> (Just Refl, Just (GetUser n)))
            = Nothing
    • Relevant bindings include
        exampleFunction :: a -> EventResult a (bound at Main.hs:124:1)

Main.hs:125:79: error:
    • Could not deduce: MethodResult a ~ Maybe a0
      from the context: t5 ~ t4
        bound by a pattern with constructor:
                  Refl :: forall k (a :: k). a :~: a,
                in an equation for ‘exampleFunction’
        at Main.hs:125:52-55
      Expected type: EventResult a
        Actual type: Maybe a0
      The type variable ‘a0’ is ambiguous
    • In the expression: Nothing
      In an equation for ‘exampleFunction’:
          exampleFunction
            (castWithWitness @GetUser -> (Just Refl, Just (GetUser n)))
            = Nothing
    • Relevant bindings include
        exampleFunction :: a -> EventResult a (bound at Main.hs:124:1)

Answer 1

在这种情况下，你想要的应该是可能的，因为一个QueryEvent或UpdateEvent是一个Method，而一个Method 是 Typeable。 Typeable 让我们可以使用 Data.Typeable 中的函数来检查我们在运行时拥有的特定类型，这是我们通常无法做到的。

这是一个独立的小例子，它不直接使用 acid-state 但开始说明这个想法:

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}

这些不是绝对必要的，但可以为 Event 上的匹配创建更好的语法。

import Data.Typeable

我们需要此模块中的函数来访问运行时输入信息。

data GetVersion = GetVersion
data GetUser = GetUser String
class Typeable a => QueryEvent a where
instance QueryEvent GetVersion where
instance QueryEvent GetUser where

一组简化的类型/类来模拟 acid-state 应该产生的结果。

pattern IsEvent p <- (cast -> Just p)

这个“模式同义词”使得我们可以在模式匹配的 LHS 上编写 IsEvent p 并使其工作方式与编写 (cast ->只是 p)。后者是一个“ View 模式”，它本质上是在输入上运行函数 cast，然后将其与 Just p 进行模式匹配。 cast 是 Data.Typeable 中定义的函数: cast::forall a b。 (Typeable a, Typeable b) => a -> Maybe b。这意味着，如果我们编写，例如，(cast -> Just GetVersion)，cast 会尝试将参数转换为 类型的值GetVersion，然后与值级 GetVersion 符号进行模式匹配；如果转换失败(暗示事件是其他事件)，cast 返回 Nothing，因此此模式不匹配。这让我们写:

exampleFunction :: QueryEvent a => a -> String
exampleFunction (IsEvent GetVersion) = "get version"
exampleFunction (IsEvent (GetUser a)) = "get user " ++ a

这就可以了:

λ> exampleFunction GetVersion
"get version"
λ> exampleFunction (GetUser "foo")
"get user foo"

---

您的情况有点复杂，因为函数的 RHS(类型)取决于输入的类型。为此，我们需要更多扩展:

{-# LANGUAGE GADTs #-}               -- For type equality
{-# LANGUAGE TypeOperators #-}       -- For type equality
{-# LANGUAGE TypeFamilies #-}        -- For EventResult
{-# LANGUAGE ScopedTypeVariables #-} -- For writing castWithWitness
{-# LANGUAGE TypeApplications #-}    -- For convenience

我们还可以将 EventResult 添加到我们的虚拟简单 QueryEvent 中:

class Typeable a => QueryEvent a where
  type EventResult a
instance QueryEvent GetVersion where
  type EventResult GetVersion = Int
instance QueryEvent GetUser where
  type EventResult GetUser = String

我们可以使用

代替 cast

castWithWitness :: forall b a. (Typeable a, Typeable b)
                => a -> Maybe (b :~: a, b)
castWithWitness x = case eqT @a @b of
                      Nothing -> Nothing
                      Just Refl -> Just (Refl, x)

@a 和 @b 使用 TypeApplications 将 eqT 应用于 的类型castWithWitness 应用于，它们通过 ScopedTypeVariables 使用类型签名中的 forall 绑定(bind)。 castWithWitness 类似于cast，但除了“casted”变量外，它还返回一个证明，证明传入的类型相同。不幸的是，这使得它使用起来有点困难:不能使用 IsEvent 模式同义词，需要直接传入相关类型:

exampleFunction :: forall a. QueryEvent a => a -> EventResult a
exampleFunction (castWithWitness @GetVersion -> Just (Refl, GetVersion)) = 1
exampleFunction (castWithWitness @GetUser -> Just (Refl, GetUser n)) = n

这是有效的，因为在每种情况下，在 Refl 上匹配后，GHC 知道函数的 RHS 上的 a 是什么，并且可以减少 EventResult 类型族。