using type classes to provide alternative implementations for when using Acid-State

Question

I wrote a web application using scotty and acid state, now i would like to use type classes to be able to provide alternative implementations for the capabilities of my application for testing. I get the general idea of it and am able to apply it so simple examples but since im am using acid state there are a lot of type classes and template haskell involved which i am not entirely comfortable with yet.

so i have these straight-forward classes for the different capabilities

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)

and i also provided instances for them for my "production" monad.

But when it comes to the database capability i cant get to work what i want.

the class looks like this

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

and the instance for the production monad works fine since it only passes the event to the update and query functions of acid state, but for a test monad i would like to have something like this: instance Db Test where dbQuery (GetVersion) = use (testDb . clientVersion) dbQuery (GetUser name) = preuse (testDb . users . ix name) dbUpdate (PutUser name user) = users %= M.insert name user ... so that I can match on GetVersion,GetUser etc. (which are generated by the template haskell function makeAcidic ... ) and specify how they should be handled in the test environment.

But I get the error:

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)

i guess thats because GetVersion, GetUser etc. all have a their different own types. So is there a way to do this?

---

Incorporating suggestions

I tried the suggestions proposed by Peter Amidon but sadly it still doesnt compile here is my test code

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

and here the error

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

In this case, what you want should be possible, because a QueryEvent or UpdateEvent is a Method, and a Method is Typeable. Typeable lets us use functions from Data.Typeable to inspect what specific type we have at runtime, which we can't really normally do.

Here's a small, self-contained example that doesn't directly use acid-state but begins to illustrate the idea:

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

These aren't strictly necessary, but make it possible to make nicer syntax for matching on Events.

import Data.Typeable

We need functions from this module to access the run-time typing information.

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

A simplified set of types/classes to emulate what acid-state should produce.

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

This "pattern synonym" makes it so that we can write IsEvent p on the LHS of a pattern match and have it work the same way as if we had written (cast -> Just p). This latter is a "view pattern" which essentially runs the function cast on the input and then pattern matches it against Just p. cast is a function defined in Data.Typeable: cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b. This means that if we write, for example, (cast -> Just GetVersion), what happens is that cast tries to convert the argument into a value of type GetVersion, which is then pattern-matched against the value-level GetVersion symbol; if the conversion fails (implying that the event is something else), cast returns Nothing, so this pattern doesn't match. This lets us write:

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

This then works:

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

---

Your situation is a bit more complicated, since the (type of) the RHS of the function depends on the type of the input. We will need some more extensions for this:

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

We can also add EventResult to our dummy simple 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

Instead of using cast, we can use

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)

The @a and @b are using TypeApplications to apply eqT to the types that castWithWitness was applied to, which are bound via ScopedTypeVariables using the forall in the type signature. castWithWitness is like cast, but in addition to the "casted" variable, it returns a proof that the passed-in types are the same. Unfortunately, this makes it a bit harder to use: the IsEvent pattern synonym can't be used, and the relevant type needs to be passed in directly:

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

This works, because in each case, after matching on Refl, GHC knows on the RHS of the function what a is and can reduce the EventResult type family.