MockPolysemy.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

import Control.Monad
import Data.Type.Equality
import Polysemy
import Polysemy.Input
import Polysemy.Internal.CustomErrors (FirstOrder)
import System.FilePath
import System.IO
import System.IO.Temp

-------------------------------------------------------------------------
-- Base mocking implementation

class Mockable (f :: Effect) where
    eqAction :: f m1 a -> f m2 b -> Maybe (a :~: b)

data Expectation (f :: Effect) where
    (:->) :: f m a -> a -> Expectation f

mockAction
    :: forall (f :: Effect) (r :: EffectRow) (m :: * -> *) a
     . (Mockable f, Member (Input (Maybe (Expectation f))) r)
    => f m a -> Sem r a
mockAction action = do
    next <- input
    case next of
        Just (expectedAction :-> expectedResult) ->
            case eqAction action expectedAction of
                Just Refl -> return expectedResult
                _ -> error "Next action didn't match expected."
        _ -> error "Extra unexpected action was performed"

reportExcess
    :: forall (f :: Effect) (r :: EffectRow)
     . (Mockable f, Member (Input (Maybe (Expectation f))) r)
    => Sem r ()
reportExcess = do
    excess <- input
    case excess of
        Nothing -> return ()
        _ -> error "Excess action was not matched."

mockEffect
    :: forall (f :: Effect) (r :: EffectRow) a
     . (FirstOrder f "reinterpret", Mockable f)
    => [Expectation f] -> Sem (f : r) a -> Sem r a
mockEffect expectations underTest = runInputList expectations $ do
    final <- reinterpret mockAction underTest
    reportExcess
    return final

-------------------------------------------------------------------------
-- Core FileSystem implementation

data FileSystem m a where
    MyReadFile :: FilePath -> FileSystem m String
    MyWriteFile :: FilePath -> String -> FileSystem m ()

makeSem ''FileSystem

fileSystemToIO :: Member (Embed IO) r => Sem (FileSystem : r) a -> Sem r a
fileSystemToIO = interpret $ \action -> case action of
    MyReadFile f -> embed (readFile f)
    MyWriteFile f bytes -> embed (writeFile f bytes)

-------------------------------------------------------------------------
-- Mock FileSystem implementation

instance Mockable FileSystem where
    eqAction (MyReadFile a) (MyReadFile b) =
        if a == b then Just Refl else Nothing
    eqAction (MyWriteFile f1 d1) (MyWriteFile f2 d2) =
        if f1 == f2 && d1 == d2 then Just Refl else Nothing
    eqAction _ _ = Nothing

-------------------------------------------------------------------------
-- Sample client code

myCopyFile :: Member FileSystem r => FilePath -> FilePath -> Sem r ()
myCopyFile a b = do
    contents <- myReadFile a
    myWriteFile b contents

testReal :: IO ()
testReal = withSystemTempDirectory "fsTest" $ \dir -> do
    writeFile (dir </> "a.txt") "contents"
    runM $ fileSystemToIO $ myCopyFile (dir </> "a.txt") (dir </> "b.txt")
    contents <- readFile (dir </> "b.txt")
    when (contents /= "contents") $ error "unexpected output"

testMock :: IO ()
testMock = runM $ mockEffect fileSystemExpectations $
    myCopyFile "/foo/a.txt" "/bar/b.txt"
  where fileSystemExpectations = [
            MyReadFile "/foo/a.txt" :-> "contents",
            MyWriteFile "/bar/b.txt" "contents" :-> ()
          ]

main :: IO ()
main = testReal >> testMock