mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-10-26 11:38:59 +03:00
Fix unit tests. Remove hedgehog-classes dependency and related utilities module
This commit is contained in:
parent
a757e56c09
commit
15261c3df8
@ -90,7 +90,6 @@ tests:
|
||||
- call-stack
|
||||
- monomer
|
||||
- hedgehog
|
||||
- hedgehog-classes
|
||||
- hspec
|
||||
- HUnit
|
||||
- silently
|
||||
|
@ -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
|
||||
|
@ -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:
|
||||
|
2
tasks.md
2
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
|
||||
|
@ -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")
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user