Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement