Fix unit tests. Remove hedgehog-classes dependency and related utilities module

2024-10-26 11:38:59 +03:00 · 2020-12-18 00:22:29 -03:00 · 2020-12-18 00:22:29 -03:00 · 15261c3df8
commit 15261c3df8
parent a757e56c09
11 changed files with 48 additions and 88 deletions
--- a/package.yaml
+++ b/package.yaml
@ -90,7 +90,6 @@ tests:
    - call-stack
    - monomer
    - hedgehog
-    - hedgehog-classes
    - hspec
    - HUnit
    - silently
--- a/stack.yaml
+++ b/stack.yaml
@ -42,7 +42,6 @@ packages:
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
 extra-deps:
- hedgehog-classes-0.2.5
 - nanovg-0.6.0.0

 # Override default flag values for local packages and extra-deps
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@ -4,13 +4,6 @@
 #   https://docs.haskellstack.org/en/stable/lock_files

 packages:
- completed:
-    hackage: hedgehog-classes-0.2.5@sha256:a37e4af8b8ddb3e92120d0a5ddd892f669fe75fc13dcfd9723850574530d1f2b,5723
-    pantry-tree:
-      size: 5192
-      sha256: 965b5001ec24cddf85cf72f15ab99d335d0b19c0c8515f8b09fdc8b8d68c89b4
-  original:
-    hackage: hedgehog-classes-0.2.5
 - completed:
    hackage: nanovg-0.6.0.0@sha256:326e73fe2c4ec56656fa42894c53a8e26b3e60449c69578f5f6da50c0ad60ed2,4146
    pantry-tree:
--- a/tasks.md
+++ b/tasks.md
@ -337,6 +337,7 @@
  - Image
    - Does adding function to return imgData from Renderer make sense? Replace imageExists?
    - Remove delay logic when adding an image
+  - Check why after click focus is not immediately shown in listView items

 - Pending
  - Add testing
@ -354,7 +355,6 @@
  - Add user documentation

 Maybe postponed after release?
-  - Check why after click focus is not immediately shown in listView items
  - Make sure WidgetTask/Node association is preserved if node location in tree changes
  - Further textField improvements
    - Handle undo history
--- a/test/unit/HedgehogUtils.hs
+++ b/test/unit/HedgehogUtils.hs
@ -1,33 +0,0 @@
-module HedgehogUtils where
-
-import Control.Monad (unless)
-import Control.Monad.IO.Class
-import Data.CallStack
-import Hedgehog
-import Hedgehog.Classes
-import Test.HUnit.Lang
-import System.IO.Silently
-
-import qualified Control.Exception as E
-
-{-- Adapted from: http://hackage.haskell.org/package/hw-hspec-hedgehog --}
-location :: HasCallStack => Maybe SrcLoc
-location = case reverse callStack of
-  (_, loc) : _ -> Just loc
-  []           -> Nothing
-
-require :: HasCallStack => Property -> Assertion
-require p = do
-  (captured, result) <- capture $ liftIO $ check p
-
-  unless result $ do
-    putStrLn captured
-    E.throwIO (HUnitFailure location $ Reason "Hedgehog property test failed")
-
-checkLaws :: HasCallStack => Gen a -> [Gen a -> Laws] -> Assertion
-checkLaws gen laws = do
-  (captured, result) <- capture $ lawsCheckOne gen laws
-
-  unless result $ do
-    putStrLn captured
-    E.throwIO (HUnitFailure location $ Reason "Hedgehog classes property test failed")
--- a/test/unit/Monomer/TestUtil.hs
+++ b/test/unit/Monomer/TestUtil.hs
@ -8,6 +8,7 @@ import Data.Text (Text)
 import Data.Sequence (Seq)
 import System.IO.Unsafe

+import qualified Data.ByteString as BS
 import qualified Data.Map.Strict as M
 import qualified Data.Text as T
 import qualified Data.Sequence as Seq
@ -100,10 +101,10 @@ mockRenderer = Renderer {
  renderText = mockRenderText,

  -- Image
-  addImage = \name action size imgData -> return (),
-  updateImage = \name imgData -> return (),
+  getImage = const . Just $ ImageDef "test" def BS.empty,
+  addImage = \name size imgData -> return (),
+  updateImage = \name size imgData -> return (),
  deleteImage = \name -> return (),
-  existsImage = const True,
  renderImage = \name rect alpha -> return ()
 }

@ -111,6 +112,7 @@ mockWenv :: s -> WidgetEnv s e
 mockWenv model = WidgetEnv {
  _weOS = "Mac OS X",
  _weRenderer = mockRenderer,
+  _weMainButton = LeftBtn,
  _weTheme = def,
  _weWindowSize = testWindowSize,
  _weGlobalKeys = M.empty,
@ -138,8 +140,8 @@ nodeUpdateSizeReq :: WidgetEnv s e -> WidgetNode s e -> (SizeReq, SizeReq)
 nodeUpdateSizeReq wenv node = (sizeReqW,  sizeReqH) where
  WidgetResult node2 _ _ = widgetInit (node ^. L.widget) wenv node
  reqNode = widgetUpdateSizeReq (node2 ^. L.widget) wenv node2
-  sizeReqW = reqNode ^. L.sizeReqW
-  sizeReqH = reqNode ^. L.sizeReqH
+  sizeReqW = reqNode ^. L.info ^. L.sizeReqW
+  sizeReqH = reqNode ^. L.info ^. L.sizeReqH

 nodeResize :: WidgetEnv s e -> Rect -> WidgetNode s e -> WidgetNode s e
 nodeResize wenv viewport node = newNode where
--- a/test/unit/Monomer/Widgets/CompositeSpec.hs
+++ b/test/unit/Monomer/Widgets/CompositeSpec.hs
@ -91,8 +91,8 @@ handleEventBasic = describe "handleEventBasic" $ do
    wenv = mockWenv def
    handleEvent :: MainModel -> MainEvt -> [EventResponse MainModel MainEvt ()]
    handleEvent model evt = [Model (model & clicks %~ (+1))]
-    buildUI model = button "Click" MainBtnClicked
-    cmpNode = composite "main" id Nothing handleEvent buildUI
+    buildUI wenv model = button "Click" MainBtnClicked
+    cmpNode = composite "main" id Nothing buildUI handleEvent
    model es = nodeHandleEventCtxModel wenv es cmpNode

 handleEventChild :: Spec
@ -113,14 +113,14 @@ handleEventChild = describe "handleEventChild" $ do
    wenv = mockWenv def
    handleChild :: ChildModel -> ChildEvt -> [EventResponse ChildModel ChildEvt MainEvt]
    handleChild model evt = [Model (model & clicks %~ (+1))]
-    buildChild model = button "Click" ChildBtnClicked
+    buildChild wenv model = button "Click" ChildBtnClicked
    handleEvent :: MainModel -> MainEvt -> [EventResponse MainModel MainEvt ()]
    handleEvent model evt = [Model (model & clicks %~ (+1))]
-    buildUI model = vstack [
+    buildUI wenv model = vstack [
        button "Click" MainBtnClicked,
-        composite "child" child Nothing handleChild buildChild
+        composite "child" child Nothing buildChild handleChild
      ]
-    cmpNode = composite "main" id Nothing handleEvent buildUI
+    cmpNode = composite "main" id Nothing buildUI handleEvent
    model es = nodeHandleEventCtxModel wenv es cmpNode

 handleEventLocalKey :: Spec
@ -135,7 +135,7 @@ handleEventLocalKey = describe "handleEventLocalKey" $
    wenv = mockWenv (TestModel "" "")
    handleEvent :: TestModel -> () -> [EventResponse TestModel () ()]
    handleEvent model evt = []
-    buildUI1 model = hstack [
+    buildUI1 wenv model = hstack [
        vstack [
          textField text1 `key` "localTxt1"
        ],
@ -143,7 +143,7 @@ handleEventLocalKey = describe "handleEventLocalKey" $
          textField text1 `key` "localTxt2"
        ]
      ]
-    buildUI2 model = hstack [
+    buildUI2 wenv model = hstack [
        vstack [
          textField text1 `key` "localTxt2"
        ],
@ -151,14 +151,14 @@ handleEventLocalKey = describe "handleEventLocalKey" $
          textField text1 `key` "localTxt1"
        ]
      ]
-    cmpNode1 = composite "main" id Nothing handleEvent buildUI1
-    cmpNode2 = composite_ "main" id Nothing handleEvent buildUI2 [mergeRequired (\_ _ -> True)]
+    cmpNode1 = composite "main" id Nothing buildUI1 handleEvent
+    cmpNode2 = composite_ "main" id Nothing buildUI2 handleEvent [mergeRequired (\_ _ -> True)]
    evts1 = [evtK keyTab, evtT "aacc", moveCharL, moveCharL]
    model1 = nodeHandleEventModel wenv evts1 cmpNode1
    (wenv1, _, oldRoot1) = fst $ nodeHandleEvents wenv evts1 cmpNode1
    cntResM = widgetMerge (cmpNode2 ^. L.widget) wenv1 oldRoot1 cmpNode2
    evts2 = [evtK keyTab, evtK keyTab, evtT "bb"]
-    modelM = nodeHandleEventModelNoInit wenv1 evts2 (cntResM ^. L.widget)
+    modelM = nodeHandleEventModelNoInit wenv1 evts2 (cntResM ^. L.node)

 handleEventGlobalKey :: Spec
 handleEventGlobalKey = describe "handleEventGlobalKey" $
@ -172,7 +172,7 @@ handleEventGlobalKey = describe "handleEventGlobalKey" $
    wenv = mockWenv (TestModel "" "")
    handleEvent :: TestModel -> () -> [EventResponse TestModel () ()]
    handleEvent model evt = []
-    buildUI1 model = hstack [
+    buildUI1 wenv model = hstack [
        vstack [
          textField text1 `globalKey` "globalTxt1"
        ],
@ -180,7 +180,7 @@ handleEventGlobalKey = describe "handleEventGlobalKey" $
          textField text1 `globalKey` "globalTxt2"
        ]
      ]
-    buildUI2 model = hstack [
+    buildUI2 wenv model = hstack [
        vstack [
          textField text1 `globalKey` "globalTxt2"
        ],
@ -188,14 +188,14 @@ handleEventGlobalKey = describe "handleEventGlobalKey" $
          textField text1 `globalKey` "globalTxt1"
        ]
      ]
-    cmpNode1 = composite "main" id Nothing handleEvent buildUI1
-    cmpNode2 = composite_ "main" id Nothing handleEvent buildUI2 [mergeRequired (\_ _ -> True)]
+    cmpNode1 = composite "main" id Nothing buildUI1 handleEvent
+    cmpNode2 = composite_ "main" id Nothing buildUI2 handleEvent [mergeRequired (\_ _ -> True)]
    evts1 = [evtK keyTab, evtT "aacc", moveCharL, moveCharL]
    model1 = nodeHandleEventModel wenv evts1 cmpNode1
    (wenv1, _, oldRoot1) = fst $ nodeHandleEvents wenv evts1 cmpNode1
    cntResM = widgetMerge (cmpNode2 ^. L.widget) wenv1 oldRoot1 cmpNode2
    evts2 = [evtK keyTab, evtK keyTab, evtT "bb"]
-    modelM = nodeHandleEventModelNoInit wenv1 evts2 (cntResM ^. L.widget)
+    modelM = nodeHandleEventModelNoInit wenv1 evts2 (cntResM ^. L.node)

 updateSizeReq :: Spec
 updateSizeReq = describe "updateSizeReq" $ do
@ -208,12 +208,12 @@ updateSizeReq = describe "updateSizeReq" $ do
  where
    wenv = mockWenv ()
    handleEvent model evt = []
-    buildUI :: () -> WidgetNode () ()
-    buildUI model = vstack [
+    buildUI :: WidgetEnv () () -> () -> WidgetNode () ()
+    buildUI wenv model = vstack [
        label "label 1",
        label "label 2"
      ]
-    cmpNode = composite "main" id Nothing handleEvent buildUI
+    cmpNode = composite "main" id Nothing buildUI handleEvent
    (sizeReqW, sizeReqH) = nodeUpdateSizeReq wenv cmpNode

 resize :: Spec
@ -231,13 +231,13 @@ resize = describe "resize" $ do
    pendingWith "Instance tree data not yet implemented"

  where
-    wenv = mockWenv () & L.appWindowSize .~ Size 640 480
+    wenv = mockWenv () & L.windowSize .~ Size 640 480
    vp   = Rect 0 0 640 480
    cvp1 = Rect 0 0 640 480
    handleEvent model evt = []
-    buildUI :: () -> WidgetNode () ()
-    buildUI model = hstack []
-    cmpNode = composite "main" id Nothing handleEvent buildUI
+    buildUI :: WidgetEnv () () -> () -> WidgetNode () ()
+    buildUI wenv model = hstack []
+    cmpNode = composite "main" id Nothing buildUI handleEvent
    newNode = nodeInit wenv cmpNode
    viewport = newNode ^. L.info . L.viewport
    childrenVp = (^. L.info . L.viewport) <$> newNode ^. L.children
--- a/test/unit/Monomer/Widgets/ContainerSpec.hs
+++ b/test/unit/Monomer/Widgets/ContainerSpec.hs
@ -66,7 +66,7 @@ handleEventNormal = describe "handleEventNormal" $
    (wenv1, _, oldRoot1) = fst $ nodeHandleEvents wenv evts1 cntNode1
    cntResM = widgetMerge (cntNode2 ^. L.widget) wenv1 oldRoot1 cntNode2
    evts2 = [evtK keyTab, evtT "bb"]
-    modelM = nodeHandleEventModelNoInit wenv1 evts2 (cntResM ^. L.widget)
+    modelM = nodeHandleEventModelNoInit wenv1 evts2 (cntResM ^. L.node)

 handleEventNoKey :: Spec
 handleEventNoKey = describe "handleEventNoKey" $
@ -91,7 +91,7 @@ handleEventNoKey = describe "handleEventNoKey" $
    (wenv1, _, oldRoot1) = fst $ nodeHandleEvents wenv evts1 cntNode1
    cntResM = widgetMerge (cntNode2 ^. L.widget) wenv1 oldRoot1 cntNode2
    evts2 = [evtK keyTab, evtK keyTab, evtT "bb"]
-    modelM = nodeHandleEventModelNoInit wenv1 evts2 (cntResM ^. L.widget)
+    modelM = nodeHandleEventModelNoInit wenv1 evts2 (cntResM ^. L.node)

 handleEventLocalKey :: Spec
 handleEventLocalKey = describe "handleEventLocalKey" $
@ -116,4 +116,4 @@ handleEventLocalKey = describe "handleEventLocalKey" $
    (wenv1, _, oldRoot1) = fst $ nodeHandleEvents wenv evts1 cntNode1
    cntResM = widgetMerge (cntNode2 ^. L.widget) wenv1 oldRoot1 cntNode2
    evts2 = [evtK keyTab, evtK keyTab, evtT "bb"]
-    modelM = nodeHandleEventModelNoInit wenv1 evts2 (cntResM ^. L.widget)
+    modelM = nodeHandleEventModelNoInit wenv1 evts2 (cntResM ^. L.node)
--- a/test/unit/Monomer/Widgets/GridSpec.hs
+++ b/test/unit/Monomer/Widgets/GridSpec.hs
@ -144,7 +144,7 @@ resizeItemsH = describe "several items, horizontal" $ do
    childrenRa `shouldBe` Seq.fromList [cvp1, cvp2, cvp3]

  where
-    wenv = mockWenv () & L.appWindowSize .~ Size 480 640
+    wenv = mockWenv () & L.windowSize .~ Size 480 640
    vp   = Rect   0 0 480 640
    cvp1 = Rect   0 0 160 640
    cvp2 = Rect 160 0 160 640
--- a/test/unit/Monomer/Widgets/StackSpec.hs
+++ b/test/unit/Monomer/Widgets/StackSpec.hs
@ -99,7 +99,7 @@ resizeFlexibleH = describe "flexible items, horizontal" $ do
    childrenRa `shouldBe` Seq.fromList [cvp1, cvp2, cvp3]

  where
-    wenv = mockWenv () & L.appWindowSize .~ Size 480 640
+    wenv = mockWenv () & L.windowSize .~ Size 480 640
    vp   = Rect   0 0 480 640
    cvp1 = Rect   0 0 112 640
    cvp2 = Rect 112 0 256 640
--- a/test/unit/Monomer/Widgets/Util/StyleSpec.hs
+++ b/test/unit/Monomer/Widgets/Util/StyleSpec.hs
@ -59,9 +59,9 @@ testHandleSizeChange :: Spec
 testHandleSizeChange = describe "handleSizeChange" $ do
  it "should request Resize widgets if sizeReq changed" $ do
    resHover ^? _Just . L.requests `shouldSatisfy` (==3) . maybeLength
-    resHover ^? _Just . L.requests . ix 0 `shouldSatisfy` isResizeWidgets
-    resHover ^? _Just . L.requests . ix 1 `shouldSatisfy` isRenderOnce
-    resHover ^? _Just . L.requests . ix 2 `shouldSatisfy` isSetCursorIcon
+    resHover ^? _Just . L.requests . ix 0 `shouldSatisfy` isMResizeWidgets
+    resHover ^? _Just . L.requests . ix 1 `shouldSatisfy` isMRenderOnce
+    resHover ^? _Just . L.requests . ix 2 `shouldSatisfy` isMSetCursorIcon

  it "should not request Resize widgets if sizeReq has not changed" $
    resFocus ^? _Just . L.requests `shouldSatisfy` (==0) . maybeLength
@ -84,17 +84,17 @@ testHandleSizeChange = describe "handleSizeChange" $ do
    resHover = handleStyleChange wenvHover path evtEnter hoverStyle Nothing node
    resFocus = handleStyleChange wenvFocus path Focus focusStyle Nothing node

-isResizeWidgets :: Maybe (WidgetRequest s) -> Bool
-isResizeWidgets (Just ResizeWidgets) = True
-isResizeWidgets _ = False
+isMResizeWidgets :: Maybe (WidgetRequest s) -> Bool
+isMResizeWidgets (Just ResizeWidgets) = True
+isMResizeWidgets _ = False

-isRenderOnce :: Maybe (WidgetRequest s) -> Bool
-isRenderOnce (Just RenderOnce{}) = True
-isRenderOnce _ = False
+isMRenderOnce :: Maybe (WidgetRequest s) -> Bool
+isMRenderOnce (Just RenderOnce{}) = True
+isMRenderOnce _ = False

-isSetCursorIcon :: Maybe (WidgetRequest s) -> Bool
-isSetCursorIcon (Just SetCursorIcon{}) = True
-isSetCursorIcon _ = False
+isMSetCursorIcon :: Maybe (WidgetRequest s) -> Bool
+isMSetCursorIcon (Just SetCursorIcon{}) = True
+isMSetCursorIcon _ = False

 maybeLength :: Maybe (Seq a) -> Int
 maybeLength Nothing = 0