mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-11 20:07:26 +03:00
Do not run tests involving copy/paste unless environment variable USE_SDL_VIDEO_SUBSYSTEM = 1 (#35)
This commit is contained in:
parent
9f02be85ca
commit
4accc0cb82
@ -506,7 +506,7 @@ test-suite monomer-test
|
||||
test/unit
|
||||
default-extensions:
|
||||
OverloadedStrings
|
||||
ghc-options: -threaded -fwarn-incomplete-patterns
|
||||
ghc-options: -fwarn-incomplete-patterns
|
||||
build-depends:
|
||||
HUnit ==1.6.*
|
||||
, JuicyPixels >=3.2.9 && <3.5
|
||||
|
@ -152,7 +152,6 @@ tests:
|
||||
main: Spec.hs
|
||||
source-dirs: test/unit
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -fwarn-incomplete-patterns
|
||||
dependencies:
|
||||
- directory >= 1.3 && < 1.4
|
||||
|
@ -20,7 +20,9 @@ import Data.Default
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Sequence (Seq)
|
||||
import System.IO.Unsafe
|
||||
import System.Environment (lookupEnv)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.Hspec (Expectation, pendingWith)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Map.Strict as M
|
||||
@ -348,3 +350,15 @@ roundRectUnits (Rect x y w h) = Rect nx ny nw nh where
|
||||
ny = fromIntegral (round y)
|
||||
nw = fromIntegral (round w)
|
||||
nh = fromIntegral (round h)
|
||||
|
||||
useVideoSubSystem :: IO Bool
|
||||
useVideoSubSystem = do
|
||||
(== Just "1") <$> lookupEnv "USE_SDL_VIDEO_SUBSYSTEM"
|
||||
|
||||
testInVideoSubSystem :: Expectation -> Expectation
|
||||
testInVideoSubSystem expectation = do
|
||||
useVideo <- useVideoSubSystem
|
||||
if useVideo then
|
||||
expectation
|
||||
else
|
||||
pendingWith "SDL Video sub system not initialized. Skipping."
|
||||
|
@ -105,12 +105,16 @@ handleEvent = describe "handleEvent" $ do
|
||||
it "should copy and paste text around" $ do
|
||||
let str = "This is some long text"
|
||||
let steps = [evtT str, selWordL, selWordL, selCharL, evtKG keyC, moveWordL, moveWordL, moveCharL, evtKG keyV]
|
||||
model steps ^. textValue `shouldBe` "This long text is some long text"
|
||||
|
||||
testInVideoSubSystem $
|
||||
model steps ^. textValue `shouldBe` "This long text is some long text"
|
||||
|
||||
it "should cut and paste text around" $ do
|
||||
let str = "This is long text"
|
||||
let steps = [evtT str, selWordL, selCharL, evtKG keyX, moveWordL, moveWordL, moveCharL, evtKG keyV]
|
||||
model steps ^. textValue `shouldBe` "This text is long"
|
||||
|
||||
testInVideoSubSystem $
|
||||
model steps ^. textValue `shouldBe` "This text is long"
|
||||
|
||||
it "should generate an event when focus is received" $ do
|
||||
events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath)
|
||||
@ -173,7 +177,9 @@ handleEventValue = describe "handleEventValue" $ do
|
||||
|
||||
it "should input 'abc123', move to beginning, select three letters, copy, move to end, paste" $ do
|
||||
let steps = [evtT "abc123", evtKC keyHome, selCharR, selCharR, selCharR, evtKG keyC, evtK keyEnd, evtKG keyV]
|
||||
lastEvt steps `shouldBe` TextChanged "abc123abc"
|
||||
|
||||
testInVideoSubSystem $
|
||||
lastEvt steps `shouldBe` TextChanged "abc123abc"
|
||||
|
||||
it "should input a-b-c-d on separate lines, then press Return" $ do
|
||||
let steps = [evtT "a\nb\nc\nd", evtK keyReturn]
|
||||
|
@ -95,12 +95,16 @@ handleEvent = describe "handleEvent" $ do
|
||||
it "should copy and paste text around" $ do
|
||||
let str = "This is some long text"
|
||||
let steps = [evtT str, selWordL, selWordL, selCharL, evtKG keyC, moveWordL, moveWordL, moveCharL, evtKG keyV]
|
||||
model steps ^. textValue `shouldBe` "This long text is some long text"
|
||||
|
||||
testInVideoSubSystem $
|
||||
model steps ^. textValue `shouldBe` "This long text is some long text"
|
||||
|
||||
it "should cut and paste text around" $ do
|
||||
let str = "This is long text"
|
||||
let steps = [evtT str, selWordL, selCharL, evtKG keyX, moveWordL, moveWordL, moveCharL, evtKG keyV]
|
||||
model steps ^. textValue `shouldBe` "This text is long"
|
||||
|
||||
testInVideoSubSystem $
|
||||
model steps ^. textValue `shouldBe` "This text is long"
|
||||
|
||||
it "should generate an event when focus is received" $ do
|
||||
events [evtFocus] `shouldBe` Seq.singleton (GotFocus emptyPath)
|
||||
@ -158,7 +162,9 @@ handleEventValue = describe "handleEventValue" $ do
|
||||
|
||||
it "should input 'abc123', move to beginning, select three letters, copy, move to end, paste" $ do
|
||||
let steps = [evtT "abc123", evtKC keyHome, selCharR, selCharR, selCharR, evtKG keyC, evtK keyEnd, evtKG keyV]
|
||||
lastEvt steps `shouldBe` TextChanged "abc123abc"
|
||||
|
||||
testInVideoSubSystem $
|
||||
lastEvt steps `shouldBe` TextChanged "abc123abc"
|
||||
|
||||
where
|
||||
wenv = mockWenv (TestModel "")
|
||||
|
@ -5,6 +5,8 @@ import Test.Hspec
|
||||
import qualified SDL
|
||||
import qualified SDL.Raw as Raw
|
||||
|
||||
import Monomer.TestUtil (useVideoSubSystem)
|
||||
|
||||
import qualified Monomer.Common.CursorIconSpec as CursorIconSpec
|
||||
import qualified Monomer.Core.SizeReqSpec as SizeReqSpec
|
||||
import qualified Monomer.Graphics.UtilSpec as GraphicsUtilSpec
|
||||
@ -55,13 +57,19 @@ import qualified Monomer.Widgets.Util.TextSpec as TextSpec
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
-- Initialize SDL
|
||||
SDL.initialize [SDL.InitVideo]
|
||||
-- Run tests
|
||||
hspec spec
|
||||
-- Shutdown SDL
|
||||
Raw.quitSubSystem Raw.SDL_INIT_VIDEO
|
||||
SDL.quit
|
||||
initVideo <- useVideoSubSystem
|
||||
|
||||
if initVideo then do
|
||||
-- Initialize SDL
|
||||
SDL.initialize [SDL.InitVideo]
|
||||
-- Run tests
|
||||
hspec spec
|
||||
-- Shutdown SDL
|
||||
Raw.quitSubSystem Raw.SDL_INIT_VIDEO
|
||||
SDL.quit
|
||||
else do
|
||||
-- Run tests
|
||||
hspec spec
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
|
Loading…
Reference in New Issue
Block a user