Advertisement
Guest User

Untitled

a guest
Sep 18th, 2019
135
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 3.61 KB | None | 0 0
  1. {-# LANGUAGE DataKinds #-}
  2. {-# LANGUAGE FlexibleContexts #-}
  3. {-# LANGUAGE FlexibleInstances #-}
  4. {-# LANGUAGE GADTs #-}
  5. {-# LANGUAGE MultiParamTypeClasses #-}
  6. {-# LANGUAGE NoMonomorphismRestriction #-}
  7. {-# LANGUAGE PolyKinds #-}
  8. {-# LANGUAGE RankNTypes #-}
  9. {-# LANGUAGE ScopedTypeVariables #-}
  10. {-# LANGUAGE StandaloneDeriving #-}
  11. {-# LANGUAGE TemplateHaskell #-}
  12. {-# LANGUAGE TypeApplications #-}
  13. {-# LANGUAGE TypeOperators #-}
  14.  
  15. import Control.Monad
  16. import Data.Type.Equality
  17. import Polysemy
  18. import Polysemy.Input
  19. import Polysemy.Internal.CustomErrors (FirstOrder)
  20. import System.FilePath
  21. import System.IO
  22. import System.IO.Temp
  23.  
  24. -------------------------------------------------------------------------
  25. -- Base mocking implementation
  26.  
  27. class Mockable (f :: Effect) where
  28. eqAction :: f m1 a -> f m2 b -> Maybe (a :~: b)
  29.  
  30. data Expectation (f :: Effect) where
  31. (:->) :: f m a -> a -> Expectation f
  32.  
  33. mockAction
  34. :: forall (f :: Effect) (r :: EffectRow) (m :: * -> *) a
  35. . (Mockable f, Member (Input (Maybe (Expectation f))) r)
  36. => f m a -> Sem r a
  37. mockAction action = do
  38. next <- input
  39. case next of
  40. Just (expectedAction :-> expectedResult) ->
  41. case eqAction action expectedAction of
  42. Just Refl -> return expectedResult
  43. _ -> error "Next action didn't match expected."
  44. _ -> error "Extra unexpected action was performed"
  45.  
  46. reportExcess
  47. :: forall (f :: Effect) (r :: EffectRow)
  48. . (Mockable f, Member (Input (Maybe (Expectation f))) r)
  49. => Sem r ()
  50. reportExcess = do
  51. excess <- input
  52. case excess of
  53. Nothing -> return ()
  54. _ -> error "Excess action was not matched."
  55.  
  56. mockEffect
  57. :: forall (f :: Effect) (r :: EffectRow) a
  58. . (FirstOrder f "reinterpret", Mockable f)
  59. => [Expectation f] -> Sem (f : r) a -> Sem r a
  60. mockEffect expectations underTest = runInputList expectations $ do
  61. final <- reinterpret mockAction underTest
  62. reportExcess
  63. return final
  64.  
  65. -------------------------------------------------------------------------
  66. -- Core FileSystem implementation
  67.  
  68. data FileSystem m a where
  69. MyReadFile :: FilePath -> FileSystem m String
  70. MyWriteFile :: FilePath -> String -> FileSystem m ()
  71.  
  72. makeSem ''FileSystem
  73.  
  74. fileSystemToIO :: Member (Embed IO) r => Sem (FileSystem : r) a -> Sem r a
  75. fileSystemToIO = interpret $ \action -> case action of
  76. MyReadFile f -> embed (readFile f)
  77. MyWriteFile f bytes -> embed (writeFile f bytes)
  78.  
  79. -------------------------------------------------------------------------
  80. -- Mock FileSystem implementation
  81.  
  82. instance Mockable FileSystem where
  83. eqAction (MyReadFile a) (MyReadFile b) =
  84. if a == b then Just Refl else Nothing
  85. eqAction (MyWriteFile f1 d1) (MyWriteFile f2 d2) =
  86. if f1 == f2 && d1 == d2 then Just Refl else Nothing
  87. eqAction _ _ = Nothing
  88.  
  89. -------------------------------------------------------------------------
  90. -- Sample client code
  91.  
  92. myCopyFile :: Member FileSystem r => FilePath -> FilePath -> Sem r ()
  93. myCopyFile a b = do
  94. contents <- myReadFile a
  95. myWriteFile b contents
  96.  
  97. testReal :: IO ()
  98. testReal = withSystemTempDirectory "fsTest" $ \dir -> do
  99. writeFile (dir </> "a.txt") "contents"
  100. runM $ fileSystemToIO $ myCopyFile (dir </> "a.txt") (dir </> "b.txt")
  101. contents <- readFile (dir </> "b.txt")
  102. when (contents /= "contents") $ error "unexpected output"
  103.  
  104. testMock :: IO ()
  105. testMock = runM $ mockEffect fileSystemExpectations $
  106. myCopyFile "/foo/a.txt" "/bar/b.txt"
  107. where fileSystemExpectations = [
  108. MyReadFile "/foo/a.txt" :-> "contents",
  109. MyWriteFile "/bar/b.txt" "contents" :-> ()
  110. ]
  111.  
  112. main :: IO ()
  113. main = testReal >> testMock
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement