использование классов типов для обеспечения альтернативных реализаций при использовании Acid-State

Question

Я написал веб-приложение, используя состояние Скотти и Кислоты, теперь я хотел бы использовать классы типов, чтобы иметь возможность предоставлять альтернативные реализации для возможностей моего приложения для тестирования.Я получил общее представление об этом и смог применить его на таких простых примерах, но так как я использую кислотное состояние, есть много классов типов и шаблонов 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)

, и я также предоставил экземпляры для них для моей "производственной" монады.

Но когда дело доходит до возможностей базы данных, я не могу заставить работать то, что я хочу.

класс выглядит так

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

и экземпляр для производственной монадыработает нормально, поскольку передает событие только функциям update и query кислотного состояния, но для тестовой монады мне хотелось бы иметь что-то вроде этого: экземпляр Db Test, где dbQuery (GetVersion) = use (testDb. clientVersion) dbQuery (GetUsername) = 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 и т. Д. Есть разные типы.Так есть ли способ сделать это?

---

Включение предложений

Я попробовал предложения, предложенные Питером Амидоном, но, к сожалению, он все еще не компилируется, вот мой тестовый код

{-# 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 s.

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)

Этот «синоним шаблона» делает так, что мы можем записать IsEvent p в LHS соответствия шаблона и заставить его работать так же, как если бы мы написали (cast -> Just p).Этот последний является «шаблоном представления», который, по сути, запускает функцию 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 в подписи типа.castWithWitness похоже на cast, но в дополнение к «приведенной» переменной он возвращает доказательство того, что переданные типы одинаковы.К сожалению, это усложняет использование: синоним шаблона 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.