terminal-0.2.0.0: test/Spec/Virtual.hs
module Spec.Virtual (tests) where
import Control.Monad
import Control.Monad.STM
import Control.Concurrent.STM.TVar
import Data.Monoid
import Test.Tasty
import Test.Tasty.HUnit
import System.Terminal
import System.Terminal.Internal
tests :: TestTree
tests = testGroup "System.Terminal.Virtual"
[ testGroup "withVirtualTerminal"
[ testWithVirtualTerminal01
]
, testGroup "PutLn"
[ testPutLn01
, testPutLn02
, testPutLn03
]
, testGroup "PutText"
[ testPutText01
, testPutText02
, testPutText03
, testPutText04
]
, testGroup "MoveCursor*"
[ testMoveCursor01
, testMoveCursor02
, testMoveCursor03
, testMoveCursor04
]
, testGroup "GetCursorPosition"
[ testGetCursorPosition01
]
, testGroup "SetCursorPosition"
[ testSetCursorPosition01
, testSetCursorPosition02
, testSetCursorPosition03
, testSetCursorPosition04
, testSetCursorPosition05
]
, testGroup "SetCursorRow"
[ testSetCursorRow01
]
, testGroup "SetCursorColumn"
[ testSetCursorColumn
]
, testGroup "InsertChars"
[ testInsertChars01
]
, testGroup "DeleteChars"
[ testDeleteChars01
]
, testGroup "EraseChars"
[ testEraseChars01
]
, testGroup "InsertLines"
[ testInsertLines01
]
, testGroup "DeleteLines"
[ testDeleteLines01
]
, testGroup "EraseInLine"
[ testEraseInLine01
, testEraseInLine02
, testEraseInLine03
]
, testGroup "EraseInDisplay"
[ testEraseInDisplay01
, testEraseInDisplay02
, testEraseInDisplay03
]
]
defaultSettings :: VirtualTerminalSettings
defaultSettings = VirtualTerminalSettings
{ virtualType = "xterm"
, virtualWindowSize = pure (Size 4 10)
, virtualEvent = retry
, virtualInterrupt = retry
}
testWithVirtualTerminal01 :: TestTree
testWithVirtualTerminal01 =
testCase "shall yield empty window and cursor on home position" do
t <- withVirtualTerminal settings pure
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 0 0
expWindow =
[ " "
, " "
, " " ]
testPutLn01 :: TestTree
testPutLn01 =
testCase "shall set cursor to next line" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t PutLn
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 1 0
expWindow =
[ " "
, " "
, " " ]
testPutLn02 :: TestTree
testPutLn02 =
testCase "shall not exceed bottom margin" do
t <- withVirtualTerminal settings $ \t -> do
replicateM_ 6 (termCommand t PutLn)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 2 0
expWindow =
[ " "
, " "
, " " ]
testPutLn03 :: TestTree
testPutLn03 =
testCase "shall scroll when reaching bottom margin" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "ABC")
termCommand t PutLn
termCommand t (PutText "123")
termCommand t PutLn
termCommand t PutLn
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 2 0
expWindow =
[ "123 "
, " "
, " " ]
testPutText01 :: TestTree
testPutText01 =
testCase "shall put text in first line" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "ABC")
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 0 3
expWindow =
[ "ABC "
, " "
, " " ]
testPutText02 :: TestTree
testPutText02 =
testCase "shall wrap text around (when autoWrap is on)" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (SetAutoWrap True)
termCommand t (PutText "ABC")
termCommand t (PutText "123456789")
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 1 2
expWindow =
[ "ABC1234567"
, "89 "
, " " ]
testPutText03 :: TestTree
testPutText03 =
testCase "shall not wrap text around (when autoWrap is off)" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (SetAutoWrap False)
termCommand t (PutText "ABC")
termCommand t (PutText "123456789")
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 0 9
expWindow =
[ "ABC1234567"
, " "
, " " ]
testPutText04 :: TestTree
testPutText04 =
testCase "shall scroll when reaching bottom margin" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890ABCDEFGHIJabcdefghijX")
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 2 1
expWindow =
[ "ABCDEFGHIJ"
, "abcdefghij"
, "X " ]
testMoveCursor01 :: TestTree
testMoveCursor01 =
testCase "shall move up" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (MoveCursorUp 1)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 0 5
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testMoveCursor02 :: TestTree
testMoveCursor02 =
testCase "shall move down" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (MoveCursorDown 1)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 2 5
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testMoveCursor03 :: TestTree
testMoveCursor03 =
testCase "shall move forward" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (MoveCursorForward 2)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 1 7
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testMoveCursor04 :: TestTree
testMoveCursor04 =
testCase "shall move backward" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (MoveCursorBackward 2)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 1 3
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testGetCursorPosition01 :: TestTree
testGetCursorPosition01 =
testCase "shall return cursor position" do
pos <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termGetCursorPosition t
assertEqual "cursor" expCursor pos
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 1 5
testSetCursorPosition01 :: TestTree
testSetCursorPosition01 =
testCase "shall set cursor position" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (SetCursorPosition (Position 2 8))
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 2 8
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testSetCursorPosition02 :: TestTree
testSetCursorPosition02 =
testCase "shall set cursor position (limit top margin)" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (SetCursorPosition $ Position (-1) 8)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 0 8
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testSetCursorPosition03 :: TestTree
testSetCursorPosition03 =
testCase "shall set cursor position (limit bottom margin)" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (SetCursorPosition (Position 5 8))
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 2 8
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testSetCursorPosition04 :: TestTree
testSetCursorPosition04 =
testCase "shall set cursor position (limit left margin)" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (SetCursorPosition $ Position 1 (-1))
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 1 0
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testSetCursorPosition05 :: TestTree
testSetCursorPosition05 =
testCase "shall set cursor position (limit right margin)" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (SetCursorPosition (Position 1 11))
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 1 9
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testSetCursorRow01 :: TestTree
testSetCursorRow01 =
testCase "shall set vertical cursor position" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (SetCursorRow 2)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 2 5
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testSetCursorColumn :: TestTree
testSetCursorColumn =
testCase "shall set horizontal cursor position" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "123456789012345")
termCommand t (SetCursorColumn 8)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = Position 1 8
expWindow =
[ "1234567890"
, "12345 "
, " " ]
testInsertChars01 :: TestTree
testInsertChars01 =
testCase "shall insert space and shift out existing chars" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (SetCursorPosition (Position 0 4))
termCommand t (InsertChars 3)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = (Position 0 4)
expWindow =
[ "1234 567"
, " "
, " " ]
testDeleteChars01 :: TestTree
testDeleteChars01 =
testCase "shall shift chars from right and fill with whitespace" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (SetCursorPosition (Position 0 4))
termCommand t (DeleteChars 3)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = (Position 0 4)
expWindow =
[ "1234890 "
, " "
, " " ]
testEraseChars01 :: TestTree
testEraseChars01 =
testCase "shall override chars with spaces" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (SetCursorPosition (Position 0 4))
termCommand t (EraseChars 3)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = (Position 0 4)
expWindow =
[ "1234 890"
, " "
, " " ]
testInsertLines01 :: TestTree
testInsertLines01 =
testCase "shall shift lines cursor and below downwards" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (PutText "ABCDEFGHIJ")
termCommand t (PutText "QRSTUVWXYZ")
termCommand t (SetCursorPosition (Position 1 4))
termCommand t (InsertLines 1)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure (Size 4 10)
}
expCursor = (Position 1 4)
expWindow =
[ "1234567890"
, " "
, "ABCDEFGHIJ"
, "QRSTUVWXYZ" ]
testDeleteLines01 :: TestTree
testDeleteLines01 =
testCase "shall shift chars from right and fill with whitespace" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (PutText "ABCDEFGHIJ")
termCommand t (PutText "QRSTUVWXYZ")
termCommand t (SetCursorPosition (Position 1 4))
termCommand t (InsertLines 1)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure (Size 4 10)
}
expCursor = (Position 1 4)
expWindow =
[ "1234567890"
, " "
, "ABCDEFGHIJ"
, "QRSTUVWXYZ" ]
testEraseInLine01 :: TestTree
testEraseInLine01 =
testCase "shall erase left with EraseBackward" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (SetCursorPosition (Position 1 4))
termCommand t (EraseInLine EraseBackward)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = (Position 1 4)
expWindow =
[ "1234567890"
, " 67890"
, "1234567890" ]
testEraseInLine02 :: TestTree
testEraseInLine02 =
testCase "shall erase right with EraseForward" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (SetCursorPosition (Position 1 4))
termCommand t (EraseInLine EraseForward)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = (Position 1 4)
expWindow =
[ "1234567890"
, "1234 "
, "1234567890" ]
testEraseInLine03 :: TestTree
testEraseInLine03 =
testCase "shall erase whole line with EraseAll" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (SetCursorPosition (Position 1 4))
termCommand t (EraseInLine EraseAll)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = (Position 1 4)
expWindow =
[ "1234567890"
, " "
, "1234567890" ]
testEraseInDisplay01 :: TestTree
testEraseInDisplay01 =
testCase "shall erase left with EraseBackward" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (SetCursorPosition (Position 1 4))
termCommand t (EraseInDisplay EraseBackward)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = (Position 1 4)
expWindow =
[ " "
, "1234567890"
, "1234567890" ]
testEraseInDisplay02 :: TestTree
testEraseInDisplay02 =
testCase "shall erase right with EraseForward" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (SetCursorPosition (Position 1 4))
termCommand t (EraseInDisplay EraseForward)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = (Position 1 4)
expWindow =
[ "1234567890"
, "1234567890"
, " " ]
testEraseInDisplay03 :: TestTree
testEraseInDisplay03 =
testCase "shall erase whole line with EraseAll" do
t <- withVirtualTerminal settings $ \t -> do
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (PutText "1234567890")
termCommand t (SetCursorPosition (Position 1 4))
termCommand t (EraseInDisplay EraseAll)
pure t
assertEqual "window" expWindow =<< readTVarIO (virtualWindow t)
assertEqual "cursor" expCursor =<< readTVarIO (virtualCursor t)
where
settings = defaultSettings
{ virtualWindowSize = pure $ Size 3 10
}
expCursor = (Position 1 4)
expWindow =
[ " "
, " "
, " " ]