Unit testing Tagless Final approach using DataKinds for mocking

TaglessFinalMockDataKinds.hs

import           Control.Monad.Reader
import           Control.Monad.Identity
import           Test.Hspec

-- Reference: https://chrispenner.ca/posts/mock-effects-with-data-kinds

newtype UserName = UserName String deriving (Eq, Show, Ord)
newtype Data = Data String deriving (Show, Eq)
newtype AppConfig = AppConfig String deriving Show
newtype LogMsg = LogMsg String deriving Show

class Monad m => Cache m where
  getFromCache :: UserName -> m (Maybe Data)
  storeInCache :: UserName -> Data -> m ()

class Monad m => DataSource m where
  getFromSource :: UserName -> m (Maybe Data)
  storeInSource :: UserName -> Data -> m ()

class Monad m => Logger m where
  logMsg :: LogMsg -> m ()


storeData
  :: (MonadReader AppConfig m, Cache m, DataSource m, Logger m)
  => UserName
  -> Data
  -> m ()
storeData userName data' = do
  cfg <- ask
  logMsg $ LogMsg $ show cfg <> " is read as config"
  storeInSource userName data'
  logMsg $ LogMsg $ show userName <> " is stored in database"
  storeInCache userName data'
  logMsg $ LogMsg $ show userName <> " is stored in cache"

requestData
  :: (MonadReader AppConfig m, Cache m, DataSource m, Logger m)
  => UserName
  -> m (Maybe Data)
requestData userName = do
  cfg <- ask
  logMsg $ LogMsg $ show cfg <> " is read as config"
  cached <- getFromCache userName
  case cached of
    Just result -> do
      logMsg $ LogMsg $ show userName <> " found in cache"
      return $ Just result
    Nothing -> do
      logMsg $ LogMsg $ show userName <> " not found in cache"
      stored <- getFromSource userName
      case stored of
        Just result -> do
          logMsg $ LogMsg $ show userName <> " found in datasource"
          storeInCache userName result
          return $ Just result
        Nothing -> do
          logMsg $ LogMsg $ show userName <> " not found in datasource"
          return Nothing


---- Testing

data DSImpl = DSReturnsSomething | DSReturnsNothing
data CImpl = CReturnsSomething | CReturnsNothing

newtype TestM (ds :: DSImpl) (c :: CImpl) a =
  TestM { unTestM :: ReaderT AppConfig Identity a }
  deriving (Functor, Applicative, Monad, Logger, MonadReader AppConfig)

instance Logger (ReaderT AppConfig Identity) where
  logMsg _ = return ()

instance DataSource (TestM DSReturnsSomething c) where
  getFromSource (UserName userName) =
    return $ Just $ Data $ "From DS: " ++ userName
  storeInSource _ _ = return ()

instance DataSource (TestM DSReturnsNothing c) where
  getFromSource _ = return Nothing
  storeInSource _ _ = return ()

instance Cache (TestM ds CReturnsSomething) where
  getFromCache (UserName userName) =
    return $ Just $ Data $ "From Cache: " ++ userName
  storeInCache _ _ = return ()

instance Cache (TestM ds CReturnsNothing) where
  getFromCache _ = return Nothing
  storeInCache _ _ = return ()

runTest :: TestM ds c a -> a
runTest test = runIdentity $ runReaderT (unTestM test) (AppConfig "config")

spec :: IO ()
spec = hspec $ do
  describe "Requesting Data" $ do
    it "should get it from cache if found there" $ do
      let result = runTest @DSReturnsNothing @CReturnsSomething
            (requestData $ UserName "name 1")
      result `shouldBe` Just (Data "From Cache: name 1")

    it "should get it from database if not found in cache" $ do
      let result = runTest @DSReturnsSomething @CReturnsNothing
            (requestData $ UserName "name 1")
      result `shouldBe` Just (Data "From DS: name 1")

    it "should get nothing if neither found in cache nor database" $ do
      let result = runTest @DSReturnsNothing @CReturnsNothing
            (requestData $ UserName "name 1")
      result `shouldBe` Nothing

  describe "Storing data" $ do
    it "should succeed" $ do
      let result = runTest @DSReturnsSomething @CReturnsSomething
            (storeData (UserName "name 1") (Data "data"))
      result `shouldBe` ()