Generate mock call type from typeclasses th

5 files changed, 127 insertions, 107 deletions

diff --git a/chelleport.cabal b/chelleport.cabal
index 4e1482d..adef7b0 100644
--- a/chelleport.cabal
+++ b/chelleport.cabal
@@ -14,6 +14,7 @@ common common-config
     ExplicitForAll
     FlexibleContexts
     FlexibleInstances
+    GADTs
     GeneralizedNewtypeDeriving
     LambdaCase
     NamedFieldPuns
@@ -75,10 +76,12 @@ test-suite specs
   ghc-options: -Wno-name-shadowing
   other-modules:
     Mock
+    TestUtils
     Specs.KeySequenceSpec
     Specs.AppStateUpdateSpec
     Specs.AppEventSpec
     Specs.ViewSpec
   build-depends:
     lib-chelleport,
+    template-haskell,
     hspec
diff --git a/specs/Mock.hs b/specs/Mock.hs
index d0daab1..00cb64a 100644
--- a/specs/Mock.hs
+++ b/specs/Mock.hs
@@ -1,81 +1,33 @@
 module Mock where
 
-import Chelleport.AppShell (MonadAppShell (..))
-import Chelleport.Control (MonadControl (..))
-import Chelleport.Draw (MonadDraw (..))
-import Chelleport.Types
-import Control.Monad (void)
-import Control.Monad.IO.Class (MonadIO)
-import Control.Monad.State (MonadState (state), StateT (runStateT))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Foreign.C (CInt)
-import Test.Hspec
+import Control.Monad (join)
+import Language.Haskell.TH
 
-data Call
-  = CallDrawCircle Int (CInt, CInt)
-  | CallDrawLine (CInt, CInt) (CInt, CInt)
-  | CallDrawText (CInt, CInt) Color Text
-  | CallGetMousePointerPosition
-  | CallHideWindow
-  | CallPressMouseButton
-  | CallReleaseMouseButton
-  | CallMoveMousePosition CInt CInt
-  | CallClickMouseButton MouseButtonType
-  | CallSetDrawColor Color
-  | CallShowWindow
-  | CallShutdownApp
-  | CallWindowPosition
-  | CallWindowSize
-  deriving (Show, Eq)
+typeclassFunctions :: Name -> Q [(Name, Type)]
+typeclassFunctions cls = do
+  c <- reify cls
+  pure $ case c of
+    ClassI (ClassD _ _ _ _ declr) _ -> declr >>= functionName
+    _ -> []
+  where
+    functionName (SigD name typ) = [(name, typ)]
+    functionName _ = []
 
-newtype MockCalls = MockCalls {calls :: [Call]}
-  deriving (Show)
+generateMock :: [Name] -> Q [Dec]
+generateMock clss = do
+  functions <- join <$> mapM typeclassFunctions clss
+  pure [DataD [] (mkName "Call") [] Nothing (toCtor <$> functions) [deriveClause]]
+  where
+    deriveClause = DerivClause Nothing (ConT <$> [''Show, ''Eq])
 
-registerMockCall :: (MonadState MockCalls m) => Call -> m ()
-registerMockCall call =
-  void $ state (\mock -> ((), MockCalls {calls = calls mock ++ [call]}))
+    toCtor :: (Name, Type) -> Con
+    toCtor (name, typ) = NormalC (toCtorName name) ((noBang,) <$> getArgs typ)
 
-shouldHaveCalled :: (HasCallStack) => MockCalls -> Call -> Expectation
-shouldHaveCalled mock call = calls mock `shouldContain` [call]
+    getArgs :: Type -> [Type]
+    getArgs (AppT (AppT ArrowT typ) rest) = typ : getArgs rest
+    getArgs _ = []
 
-runWithMocks :: (MonadIO m) => TestM m a -> m (a, MockCalls)
-runWithMocks action = runStateT (runTestM action) (MockCalls [])
+    noBang = Bang NoSourceUnpackedness NoSourceStrictness
 
-newtype TestM m a = TestM {runTestM :: StateT MockCalls m a}
-  deriving (Functor, Applicative, Monad, MonadIO, MonadState MockCalls)
-
-instance (MonadIO m) => MonadControl (TestM m) where
-  clickMouseButton btn = registerMockCall $ CallClickMouseButton btn
-  moveMousePointer x y = registerMockCall $ CallMoveMousePosition x y
-  getMousePointerPosition = (42, 42) <$ registerMockCall CallGetMousePointerPosition
-  pressMouseButton = registerMockCall CallPressMouseButton
-  releaseMouseButton = registerMockCall CallReleaseMouseButton
-
-mockWindowWidth :: CInt
-mockWindowWidth = 1920
-
-mockWindowHeight :: CInt
-mockWindowHeight = 1080
-
-mockWindowOffsetX :: CInt
-mockWindowOffsetX = 200
-
-mockWindowOffsetY :: CInt
-mockWindowOffsetY = 100
-
-mockTextWidth :: Int
-mockTextWidth = 10
-
-instance (MonadIO m) => MonadDraw (TestM m) where
-  drawLine p1 p2 = registerMockCall $ CallDrawLine p1 p2
-  drawText p color text = (fromIntegral $ mockTextWidth * Text.length text, 0) <$ registerMockCall (CallDrawText p color text)
-  drawCircle radius p = registerMockCall $ CallDrawCircle radius p
-  setDrawColor color = registerMockCall $ CallSetDrawColor color
-  windowSize = (mockWindowWidth, mockWindowHeight) <$ registerMockCall CallWindowSize
-  windowPosition = (mockWindowOffsetX, mockWindowOffsetY) <$ registerMockCall CallWindowPosition
-
-instance (MonadIO m) => MonadAppShell (TestM m) where
-  hideWindow = registerMockCall CallHideWindow
-  showWindow = registerMockCall CallShowWindow
-  shutdownApp = registerMockCall CallShutdownApp
+    toCtorName :: Name -> Name
+    toCtorName = mkName . ("Mock_" ++) . nameBase
diff --git a/specs/Specs/AppStateUpdateSpec.hs b/specs/Specs/AppStateUpdateSpec.hs
index 59b686a..67f6fb2 100644
--- a/specs/Specs/AppStateUpdateSpec.hs
+++ b/specs/Specs/AppStateUpdateSpec.hs
@@ -4,9 +4,9 @@ import Chelleport (initialState, update)
 import Chelleport.Types
 import Chelleport.Utils (intToCInt, uniq)
 import Control.Monad (join)
-import Mock
 import qualified SDL
 import Test.Hspec
+import TestUtils
 
 test :: SpecWith ()
 test = do
@@ -71,7 +71,7 @@ test = do
 
       it "hides window and triggers mouse click" $ do
         (_, mock) <- runWithMocks $ update currentState $ TriggerMouseClick LeftClick
-        calls mock `shouldContain` [CallHideWindow, CallClickMouseButton LeftClick]
+        calls mock `shouldContain` [Mock_hideWindow, Mock_clickMouseButton LeftClick]
 
       it "continues with action ShutdownApp without updating state" $ do
         ((nextState, action), _) <- runWithMocks $ update currentState $ TriggerMouseClick LeftClick
@@ -88,10 +88,10 @@ test = do
         it "clicks multiple times" $ do
           (_, mock) <- runWithMocks $ update currentState $ TriggerMouseClick LeftClick
           calls mock
-            `shouldBe` [ CallHideWindow,
-                         CallClickMouseButton LeftClick,
-                         CallClickMouseButton LeftClick,
-                         CallClickMouseButton LeftClick
+            `shouldBe` [ Mock_hideWindow,
+                         Mock_clickMouseButton LeftClick,
+                         Mock_clickMouseButton LeftClick,
+                         Mock_clickMouseButton LeftClick
                        ]
 
       context "when repetition is 0" $ do
@@ -99,14 +99,14 @@ test = do
 
         it "clicks just once" $ do
           (_, mock) <- runWithMocks $ update currentState $ TriggerMouseClick LeftClick
-          calls mock `shouldBe` [CallHideWindow, CallClickMouseButton LeftClick]
+          calls mock `shouldBe` [Mock_hideWindow, Mock_clickMouseButton LeftClick]
 
     context "with action ChainMouseClick" $ do
       let currentState = defaultState
 
       it "hides window, triggers mouse click and shows the window again" $ do
         (_, mock) <- runWithMocks $ update currentState $ ChainMouseClick LeftClick
-        calls mock `shouldBe` [CallHideWindow, CallClickMouseButton LeftClick, CallShowWindow]
+        calls mock `shouldBe` [Mock_hideWindow, Mock_clickMouseButton LeftClick, Mock_showWindow]
 
       it "continues with action ResetKeys without updating state" $ do
         ((nextState, action), _) <- runWithMocks $ update currentState $ ChainMouseClick LeftClick
@@ -123,11 +123,11 @@ test = do
         it "clicks multiple times" $ do
           (_, mock) <- runWithMocks $ update currentState $ ChainMouseClick LeftClick
           calls mock
-            `shouldBe` [ CallHideWindow,
-                         CallClickMouseButton LeftClick,
-                         CallClickMouseButton LeftClick,
-                         CallClickMouseButton LeftClick,
-                         CallShowWindow
+            `shouldBe` [ Mock_hideWindow,
+                         Mock_clickMouseButton LeftClick,
+                         Mock_clickMouseButton LeftClick,
+                         Mock_clickMouseButton LeftClick,
+                         Mock_showWindow
                        ]
 
       context "when repetition is 0" $ do
@@ -135,7 +135,7 @@ test = do
 
         it "clicks just once" $ do
           (_, mock) <- runWithMocks $ update currentState $ ChainMouseClick LeftClick
-          calls mock `shouldBe` [CallHideWindow, CallClickMouseButton LeftClick, CallShowWindow]
+          calls mock `shouldBe` [Mock_hideWindow, Mock_clickMouseButton LeftClick, Mock_showWindow]
 
     context "with action MouseDragToggle" $ do
       context "when is dragging is true" $ do
@@ -165,7 +165,7 @@ test = do
 
       it "hides window, starts dragging and shows the window again" $ do
         (_, mock) <- runWithMocks $ update currentState MouseDragStart
-        calls mock `shouldContain` [CallHideWindow, CallPressMouseButton, CallShowWindow]
+        calls mock `shouldContain` [Mock_hideWindow, Mock_pressMouseButton, Mock_showWindow]
 
       it "does not continue or update state" $ do
         (result, _) <- runWithMocks $ update currentState MouseDragStart
@@ -176,7 +176,7 @@ test = do
 
       it "hides window, stops dragging and shows the window again" $ do
         (_, mock) <- runWithMocks $ update currentState MouseDragEnd
-        calls mock `shouldContain` [CallHideWindow, CallReleaseMouseButton, CallShowWindow]
+        calls mock `shouldContain` [Mock_hideWindow, Mock_releaseMouseButton, Mock_showWindow]
 
       it "does not continue or update state" $ do
         (result, _) <- runWithMocks $ update currentState MouseDragStart
@@ -191,7 +191,7 @@ test = do
       it "moves mouse pointer to center of cell of given coordinates" $ do
         (_, mock) <- runWithMocks $ update currentState $ MoveMousePosition (0, 0)
         mock
-          `shouldHaveCalled` CallMoveMousePosition
+          `shouldHaveCalled` Mock_moveMousePointer
             (mockWindowOffsetX + mockWindowWidth `div` columns `div` 2)
             (mockWindowOffsetY + mockWindowHeight `div` rows `div` 2)
 
@@ -213,7 +213,7 @@ test = do
       -- TODO: Test with inline mocked values
       it "increments mouse position relative to current position" $ do
         (_, mock) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -5)
-        mock `shouldHaveCalled` CallMoveMousePosition 52 37
+        mock `shouldHaveCalled` Mock_moveMousePointer 52 37
 
       it "does not continue or update state" $ do
         (result, _) <- runWithMocks $ update currentState $ IncrementMouseCursor (0, 0)
@@ -224,21 +224,21 @@ test = do
 
         it "multiplies increment" $ do
           (_, mock) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -5)
-          mock `shouldHaveCalled` CallMoveMousePosition 92 17
+          mock `shouldHaveCalled` Mock_moveMousePointer 92 17
 
       context "when repetition is 0" $ do
         let currentState = defaultState {stateRepetition = 0}
 
         it "increments just once" $ do
           (_, mock) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -5)
-          mock `shouldHaveCalled` CallMoveMousePosition 52 37
+          mock `shouldHaveCalled` Mock_moveMousePointer 52 37
 
     context "with action ShutdownApp" $ do
       let currentState = defaultState
 
       it "shuts down app" $ do
         (_, mock) <- runWithMocks $ update currentState ShutdownApp
-        mock `shouldHaveCalled` CallShutdownApp
+        mock `shouldHaveCalled` Mock_shutdownApp
 
       it "does not continue or update state" $ do
         (result, _) <- runWithMocks $ update currentState ShutdownApp
diff --git a/specs/Specs/ViewSpec.hs b/specs/Specs/ViewSpec.hs
index 285c297..7bca567 100644
--- a/specs/Specs/ViewSpec.hs
+++ b/specs/Specs/ViewSpec.hs
@@ -3,8 +3,8 @@ module Specs.ViewSpec where
 import Chelleport.Config
 import Chelleport.Types
 import Chelleport.View
-import Mock
 import Test.Hspec
+import TestUtils
 
 test :: SpecWith ()
 test = do
@@ -17,7 +17,7 @@ test = do
             stateRepetition = 1,
             stateIsDragging = False
           }
-  let drawTextCalls = filter (\case CallDrawText {} -> True; _ -> False) . calls
+  let drawTextCalls = filter (\case Mock_drawText {} -> True; _ -> False) . calls
 
   describe "#render" $ do
     context "when key sequence is empty" $ do
@@ -26,10 +26,10 @@ test = do
       it "draws matching text labels" $ do
         (_, mock) <- runWithMocks $ render currentState
         drawTextCalls mock
-          `shouldBe` [ CallDrawText (460, 10) colorWhite "ABC",
-                       CallDrawText (1420, 10) colorWhite "DEF",
-                       CallDrawText (460, 550) colorWhite "DJK",
-                       CallDrawText (1420, 550) colorWhite "JKL"
+          `shouldBe` [ Mock_drawText (460, 10) colorWhite "ABC",
+                       Mock_drawText (1420, 10) colorWhite "DEF",
+                       Mock_drawText (460, 550) colorWhite "DJK",
+                       Mock_drawText (1420, 550) colorWhite "JKL"
                      ]
 
     context "when there is a partial match" $ do
@@ -38,10 +38,10 @@ test = do
       it "draws matching text labels" $ do
         (_, mock) <- runWithMocks $ render currentState
         drawTextCalls mock
-          `shouldBe` [ CallDrawText (1420, 10) colorLightGray "D",
-                       CallDrawText (1430, 10) colorAccent "EF",
-                       CallDrawText (460, 550) colorLightGray "D",
-                       CallDrawText (470, 550) colorAccent "JK"
+          `shouldBe` [ Mock_drawText (1420, 10) colorLightGray "D",
+                       Mock_drawText (1430, 10) colorAccent "EF",
+                       Mock_drawText (460, 550) colorLightGray "D",
+                       Mock_drawText (470, 550) colorAccent "JK"
                      ]
 
     context "when key sequence is complete match" $ do
@@ -49,14 +49,14 @@ test = do
 
       it "draws only the matching label" $ do
         (_, mock) <- runWithMocks $ render currentState
-        drawTextCalls mock `shouldBe` [CallDrawText (1420, 10) colorLightGray "DEF"]
+        drawTextCalls mock `shouldBe` [Mock_drawText (1420, 10) colorLightGray "DEF"]
 
   describe "#renderKeySequence" $ do
     context "when there is a partial match" $ do
       it "draws the matched section and highlights the remaining characters" $ do
         (_, mock) <- runWithMocks $ renderKeySequence "ABC" "ABCDE" (0, 0)
         calls mock
-          `shouldBe` [CallDrawText (0, 0) colorLightGray "ABC", CallDrawText (3 * 10, 0) colorAccent "DE"]
+          `shouldBe` [Mock_drawText (0, 0) colorLightGray "ABC", Mock_drawText (3 * 10, 0) colorAccent "DE"]
 
       it "return true as the text is visible" $ do
         (isVisible, _) <- runWithMocks $ renderKeySequence "ABC" "ABCDE" (0, 0)
@@ -65,7 +65,7 @@ test = do
     context "when there is no input key sequence" $ do
       it "draws text as a single chunk" $ do
         (_, mock) <- runWithMocks $ renderKeySequence "" "ABCD" (0, 0)
-        calls mock `shouldBe` [CallDrawText (0, 0) colorWhite "ABCD"]
+        calls mock `shouldBe` [Mock_drawText (0, 0) colorWhite "ABCD"]
 
       it "return true as the text is visible" $ do
         (isVisible, _) <- runWithMocks $ renderKeySequence "" "ABCD" (0, 0)
diff --git a/specs/TestUtils.hs b/specs/TestUtils.hs
new file mode 100644
index 0000000..c98899d
--- /dev/null
+++ b/specs/TestUtils.hs
@@ -0,0 +1,65 @@
+module TestUtils where
+
+import Chelleport.AppShell (MonadAppShell (..))
+import Chelleport.Control (MonadControl (..))
+import Chelleport.Draw (MonadDraw (..))
+import Control.Monad (void)
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.State (MonadState (state), StateT (runStateT))
+import qualified Data.Text as Text
+import Foreign.C (CInt)
+import Mock
+import Test.Hspec
+
+$(generateMock [''MonadDraw, ''MonadControl, ''MonadAppShell])
+
+newtype MockCalls = MockCalls {calls :: [Call]}
+  deriving (Show)
+
+shouldHaveCalled :: (HasCallStack) => MockCalls -> Call -> Expectation
+shouldHaveCalled mock call = calls mock `shouldContain` [call]
+
+runWithMocks :: (MonadIO m) => TestM m a -> m (a, MockCalls)
+runWithMocks action = runStateT (runTestM action) (MockCalls [])
+
+newtype TestM m a = TestM {runTestM :: StateT MockCalls m a}
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState MockCalls)
+
+mockWindowWidth :: CInt
+mockWindowWidth = 1920
+
+mockWindowHeight :: CInt
+mockWindowHeight = 1080
+
+mockWindowOffsetX :: CInt
+mockWindowOffsetX = 200
+
+mockWindowOffsetY :: CInt
+mockWindowOffsetY = 100
+
+mockTextWidth :: Int
+mockTextWidth = 10
+
+registerMockCall :: (MonadState MockCalls m) => Call -> m ()
+registerMockCall call =
+  void $ state (\mock -> ((), MockCalls {calls = calls mock ++ [call]}))
+
+instance (MonadIO m) => MonadControl (TestM m) where
+  clickMouseButton btn = registerMockCall $ Mock_clickMouseButton btn
+  moveMousePointer x y = registerMockCall $ Mock_moveMousePointer x y
+  getMousePointerPosition = (42, 42) <$ registerMockCall Mock_getMousePointerPosition
+  pressMouseButton = registerMockCall Mock_pressMouseButton
+  releaseMouseButton = registerMockCall Mock_releaseMouseButton
+
+instance (MonadIO m) => MonadDraw (TestM m) where
+  drawLine p1 p2 = registerMockCall $ Mock_drawLine p1 p2
+  drawText p color text = (fromIntegral $ mockTextWidth * Text.length text, 0) <$ registerMockCall (Mock_drawText p color text)
+  drawCircle radius p = registerMockCall $ Mock_drawCircle radius p
+  setDrawColor color = registerMockCall $ Mock_setDrawColor color
+  windowSize = (mockWindowWidth, mockWindowHeight) <$ registerMockCall Mock_windowSize
+  windowPosition = (mockWindowOffsetX, mockWindowOffsetY) <$ registerMockCall Mock_windowPosition
+
+instance (MonadIO m) => MonadAppShell (TestM m) where
+  hideWindow = registerMockCall Mock_hideWindow
+  showWindow = registerMockCall Mock_showWindow
+  shutdownApp = registerMockCall Mock_shutdownApp