99bb4b8 · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

refactor Input.Internal into more specific modules

99bb4b8Corey O'Connor13 years ago

src/Graphics/Vty/Config.hsnew file+24

compare with master

unifiedsplit

@@ -0,0 +1,24 @@

1+-- | A 'Config' can be provided to mkVty to customize the applications use of vty.

2+--

3+-- Parts of the structure can be overriden by $HOME/.config/vty.config and then $VTY_CONFIG_FILE.

4+--

5+-- See also 'classifyTableUserOverrides'.

6+--

7+module Graphics.Vty.Config where

9+import Data.Default

10+

11+import System.FilePath

12+

13+data Config = Config

14+ { singleEscPeriod :: Int -- ^ AKA VTIME. The default is 100000 microseconds or 0.1 seconds.

15+ -- | Debug information about the input process is appended to the file.

16+ , debugInputLog :: Maybe FilePath

17+ } deriving (Show, Eq)

18+

19+instance Default Config where

20+ def = Config

21+ { singleEscPeriod = 100000

22+ , debugInputLog = Nothing

23+ }

24+

src/Graphics/Vty/Input.hs+3−1

@@ -40,8 +40,10 @@ module Graphics.Vty.Input ( Key(..)

40 )

41 where

43+import Graphics.Vty.Config

44+import Graphics.Vty.Input.Classify

43import Graphics.Vty.Input.Events

45import Graphics.Vty.Input.Events

44−import Graphics.Vty.Input.Internal

46+import Graphics.Vty.Input.Loop

45import Graphics.Vty.Input.Terminfo

47import Graphics.Vty.Input.Terminfo

47import Control.Applicative

49import Control.Applicative

src/Graphics/Vty/Input/Classify.hsnew file+77

@@ -0,0 +1,77 @@

1+-- This makes a kind of tri. Has space efficiency issues with large input blocks.

2+-- Likely building a parser and just applying that would be better.

3+-- I did not write this so I might just rewrite it for better understanding. Which is not the best

4+-- of reasons.

5+-- TODO: measure and rewrite if required.

6+-- TODO: The ClassifyTable interface requires this code to always assure later entries override

7+-- earlier.

8+module Graphics.Vty.Input.Classify where

10+import Graphics.Vty.Input.Events

11+

12+import Codec.Binary.UTF8.Generic (decode)

13+

14+import Data.List(tails,inits)

15+import qualified Data.Map as M( fromList, lookup )

16+import Data.Maybe ( mapMaybe )

17+import qualified Data.Set as S( fromList, member )

18+

19+import Data.Char

20+import Data.Word

21+

22+data KClass

23+ = Valid Event [Char]

24+ | Invalid

25+ | Prefix

26+ deriving(Show, Eq)

27+

28+compile :: ClassifyTable -> [Char] -> KClass

29+compile table = cl' where

30+ -- take all prefixes and create a set of these

31+ prefixSet = S.fromList $ concatMap (init . inits . fst) $ table

32+ eventForInput = M.fromList table

33+ cl' [] = Prefix

34+ cl' inputBlock = case M.lookup inputBlock eventForInput of

35+ Just e -> Valid e []

36+ Nothing -> case S.member inputBlock prefixSet of

37+ True -> Prefix

38+ -- if the inputBlock is exactly what is expected for an event then consume the whole

39+ -- block and return the event

40+ -- look up progressively smaller tails of the input block until an event is found

41+ -- The assumption is that the event that consumes the most input bytes should be

42+ -- produced.

43+ -- The test verifyFullSynInputToEvent2x verifies this.

44+ -- H: There will always be one match. The prefixSet contains, by definition, all

45+ -- prefixes of an event.

46+ False ->

47+ let inputTails = init $ tail $ tails inputBlock

48+ in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputTails of

49+ (s,e) : _ -> Valid e (drop (length s) inputBlock)

50+ -- neither a prefix or a full event. Might be interesting to log.

51+ [] -> Invalid

52+

53+classify, classifyTab :: ClassifyTable -> [Char] -> KClass

54+

55+-- As soon as

56+classify _table s@(c:_) | ord c >= 0xC2

57+ = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence

58+classify table other

59+ = classifyTab table other

60+

61+classifyUtf8 :: [Char] -> KClass

62+classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of

63+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) []

64+ _ -> Invalid -- something bad happened; just ignore and continue.

65+

66+classifyTab table = compile table

67+

68+first :: (a -> b) -> (a,c) -> (b,c)

69+first f (x,y) = (f x, y)

70+

71+utf8Length :: (Num t, Ord a, Num a) => a -> t

72+utf8Length c

73+ | c < 0x80 = 1

74+ | c < 0xE0 = 2

75+ | c < 0xF0 = 3

76+ | otherwise = 4

77+

src/Graphics/Vty/Input/Internal.hs → src/Graphics/Vty/Input/Loop.hsrenamed+4−82

@@ -7,11 +7,12 @@

7--

8-- This is an example of an algorithm where code coverage could be high, even 100%, but the

9-- behavior is still under tested. I should collect more of these examples...

10−module Graphics.Vty.Input.Internal where

10+module Graphics.Vty.Input.Loop where

12+import Graphics.Vty.Config

13+import Graphics.Vty.Input.Classify

12import Graphics.Vty.Input.Events

14import Graphics.Vty.Input.Events

14−import Codec.Binary.UTF8.Generic (decode)

15import Control.Applicative

16import Control.Applicative

16import Control.Concurrent

17import Control.Concurrent

17import Control.Lens

18import Control.Lens

@@ -21,13 +22,8 @@ import Control.Monad.Trans.State (StateT(..), evalStateT)

21import Control.Monad.Trans.Reader (ReaderT(..))

22import Control.Monad.Trans.Reader (ReaderT(..))

23import Data.Char

24import Data.Char

24−import Data.Default

25import Data.IORef

26−import Data.List(tails,inits)

26+import Data.Word (Word8)

27−import qualified Data.Map as M( fromList, lookup )

28−import Data.Maybe ( mapMaybe )

29−import qualified Data.Set as S( fromList, member )

30−import Data.Word

32import Foreign ( allocaArray, peekArray, Ptr )

28import Foreign ( allocaArray, peekArray, Ptr )

33import Foreign.C.Types (CInt(..))

29import Foreign.C.Types (CInt(..))

@@ -36,17 +32,6 @@ import System.Posix.IO (fdReadBuf)

36import System.Posix.Terminal

32import System.Posix.Terminal

37import System.Posix.Types (Fd(..))

33import System.Posix.Types (Fd(..))

39−data Config = Config

40− { singleEscPeriod :: Int -- ^ AKA VTIME. The default is 100000 microseconds or 0.1 seconds.

41− , debugInputLog :: Maybe FilePath -- ^ Debug information about the input process is appended to the file.

42− } deriving (Show, Eq)

43−

44−instance Default Config where

45− def = Config

46− { singleEscPeriod = 100000

47− , debugInputLog = Nothing

48− }

49−

50data Input = Input

35data Input = Input

51 { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh

36 { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh

52 -- the display if the next event is an 'EvResize'.

37 -- the display if the next event is an 'EvResize'.

@@ -62,12 +47,6 @@ data Input = Input

63makeLenses ''Input

48makeLenses ''Input

65−data KClass

66− = Valid Event [Char]

67− | Invalid

68− | Prefix

69− deriving(Show, Eq)

70−

71data InputBuffer = InputBuffer

50data InputBuffer = InputBuffer

72 { _ptr :: Ptr Word8

51 { _ptr :: Ptr Word8

73 , _size :: Int

52 , _size :: Int

@@ -148,63 +127,6 @@ stopIfRequested = do

148 True <- (liftIO . readIORef) =<< use stopRequestRef

127 True <- (liftIO . readIORef) =<< use stopRequestRef

149 return ()

128 return ()

150

129

151−-- This makes a kind of tri. Has space efficiency issues with large input blocks.

152−-- Likely building a parser and just applying that would be better.

153−-- I did not write this so I might just rewrite it for better understanding. Not the best of

154−-- reasons...

155−-- TODO: measure and rewrite if required.

156−-- TODO: The ClassifyTable interface requires this code to always assure later entries override

157−-- earlier.

158−compile :: ClassifyTable -> [Char] -> KClass

159−compile table = cl' where

160− -- take all prefixes and create a set of these

161− prefixSet = S.fromList $ concatMap (init . inits . fst) $ table

162− eventForInput = M.fromList table

163− cl' [] = Prefix

164− cl' inputBlock = case M.lookup inputBlock eventForInput of

165− Just e -> Valid e []

166− Nothing -> case S.member inputBlock prefixSet of

167− True -> Prefix

168− -- if the inputBlock is exactly what is expected for an event then consume the whole

169− -- block and return the event

170− -- look up progressively smaller tails of the input block until an event is found

171− -- The assumption is that the event that consumes the most input bytes should be

172− -- produced.

173− -- The test verifyFullSynInputToEvent2x verifies this.

174− -- H: There will always be one match. The prefixSet contains, by definition, all

175− -- prefixes of an event.

176− False ->

177− let inputTails = init $ tail $ tails inputBlock

178− in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputTails of

179− (s,e) : _ -> Valid e (drop (length s) inputBlock)

180− -- neither a prefix or a full event. Might be interesting to log.

181− [] -> Invalid

182−

183−classify, classifyTab :: ClassifyTable -> [Char] -> KClass

184−

185−-- As soon as

186−classify _table s@(c:_) | ord c >= 0xC2

187− = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence

188−classify table other

189− = classifyTab table other

190−

191−classifyUtf8 :: [Char] -> KClass

192−classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of

193− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) []

194− _ -> Invalid -- something bad happened; just ignore and continue.

195−

196−classifyTab table = compile table

197−

198−first :: (a -> b) -> (a,c) -> (b,c)

199−first f (x,y) = (f x, y)

200−

201−utf8Length :: (Num t, Ord a, Num a) => a -> t

202−utf8Length c

203− | c < 0x80 = 1

204− | c < 0xE0 = 2

205− | c < 0xF0 = 3

206− | otherwise = 4

207−

208runInputProcessorLoop :: ClassifyTable -> Input -> IORef Bool -> IO ()

130runInputProcessorLoop :: ClassifyTable -> Input -> IORef Bool -> IO ()

209runInputProcessorLoop classifyTable input stopFlag = do

131runInputProcessorLoop classifyTable input stopFlag = do

210 let bufferSize = 1024

132 let bufferSize = 1024

src/Graphics/Vty/Input/Terminfo.hs+1−1

@@ -41,7 +41,7 @@ classifyTableForTerm termName term =

41 : termSpecificTables termName

43-- | The user can specify a list of classify table entries in $HOME/.config/vty.conf and

44−-- $VTY_INPUT_CONFIG. The file at $VTY_INPUT_CONFIG takes precedence over the input.conf file. Both

44+-- $VTY_CONFIG_FILE. The file at $VTY_CONFIG_FILE takes precedence over the input.conf file. Both

45-- take precedence over the classify tables determined by 'classifyTableForTerm'

46--

47-- Each line of the input config is processed individually. Lines that fail to parse are ignored.

test/VerifyConfig.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# LANGUAGE QuasiQuotes #-}

2+module Main where

4+import Graphics.Vty.Config

6+import Control.Applicative

7+import Control.Exception

8+import Control.Lens ((^.))

9+import Control.Monad

10+

11+import Data.Default

12+import Data.String.QQ

13+

14+import Test.Framework

15+import Test.Framework.Providers.HUnit

16+import Test.HUnit hiding (Test)

17+

18+import Text.Printf

19+

20+exampleConfig :: String

21+exampleConfig = [s|

22+map "\ESC[B" KUp []

23+map "\ESC[1;3B" KDown [MAlt]

24+|]

25+

26+exampleConfigParses :: IO ()

27+exampleConfigParses = return ()

28+

29+main :: IO ()

30+main = defaultMain

31+ [ testCase "example config parses" $ exampleConfigParses

32+ ]

33+

test/VerifyUsingMockInput.hs+1−1

@@ -11,7 +11,7 @@ import Data.List (intersperse)

12import Graphics.Vty hiding (resize)

13import Graphics.Vty.Input.Events

14−import Graphics.Vty.Input.Internal

14+import Graphics.Vty.Input.Loop

15import Graphics.Vty.Input.Terminfo

17import Control.Applicative

vty.cabal+44−1

@@ -14,6 +14,10 @@ description:

14 Included in the source distribution is a program test/interactive_terminal_test.hs that

15 demonstrates the various features.

16 .

17+ Developers: See the "Graphics.Vty" module.

18+ .

19+ Users: See the "Graphics.Vty.Config" module.

20+ .

17 If your terminal is not behaving as expected the results of the vty-interactive-terminal-test

21 If your terminal is not behaving as expected the results of the vty-interactive-terminal-test

18 executable should be sent to the Vty maintainter to aid in debugging the issue.

22 executable should be sent to the Vty maintainter to aid in debugging the issue.

19 .

23 .

@@ -44,6 +48,7 @@ library

44 containers,

48 containers,

45 data-default >= 0.5.3,

49 data-default >= 0.5.3,

46 deepseq >= 1.1 && < 1.4,

50 deepseq >= 1.1 && < 1.4,

51+ filepath >= 1.0 && < 2.0,

47 lens >= 3.9.0.2 && < 5.0,

52 lens >= 3.9.0.2 && < 5.0,

48 -- required for nice installation with yi

53 -- required for nice installation with yi

49 hashable >= 1.2,

54 hashable >= 1.2,

@@ -59,6 +64,7 @@ library

60 exposed-modules: Graphics.Vty

65 exposed-modules: Graphics.Vty

61 Graphics.Vty.Attributes

66 Graphics.Vty.Attributes

67+ Graphics.Vty.Config

62 Graphics.Vty.Error

68 Graphics.Vty.Error

63 Graphics.Vty.Image

69 Graphics.Vty.Image

64 Graphics.Vty.Inline

70 Graphics.Vty.Inline

@@ -76,7 +82,8 @@ library

76 Graphics.Vty.Debug

82 Graphics.Vty.Debug

77 Graphics.Vty.DisplayAttributes

83 Graphics.Vty.DisplayAttributes

78 Graphics.Vty.Image.Internal

84 Graphics.Vty.Image.Internal

79− Graphics.Vty.Input.Internal

85+ Graphics.Vty.Input.Classify

86+ Graphics.Vty.Input.Loop

80 Graphics.Vty.Input.Terminfo

87 Graphics.Vty.Input.Terminfo

81 Graphics.Vty.PictureToSpans

88 Graphics.Vty.PictureToSpans

82 Graphics.Vty.Span

89 Graphics.Vty.Span

@@ -546,3 +553,39 @@ test-suite verify-using-mock-input

546

553

547 ghc-options: -threaded -Wall

554 ghc-options: -threaded -Wall

548

555

556+test-suite verify-config

557+ default-language: Haskell2010

558+ default-extensions: ScopedTypeVariables

559+

560+ type: exitcode-stdio-1.0

561+

562+ hs-source-dirs: test

563+

564+ main-is: VerifyConfig.hs

565+

566+ build-depends: vty,

567+ Cabal == 1.18.*,

568+ data-default >= 0.5.3,

569+ HUnit,

570+ QuickCheck >= 2.4,

571+ smallcheck == 1.*,

572+ quickcheck-assertions >= 0.1.1,

573+ test-framework == 0.8.*,

574+ test-framework-smallcheck == 0.2.*,

575+ test-framework-hunit,

576+ random == 1.0.*,

577+ base >= 4 && < 5,

578+ bytestring,

579+ containers,

580+ deepseq >= 1.1 && < 1.4,

581+ lens >= 3.9.0.2 && < 5.0,

582+ mtl >= 1.1.1.0 && < 2.2,

583+ string-qq,

584+ terminfo >= 0.3 && < 0.5,

585+ text >= 0.11.3,

586+ unix,

587+ utf8-string >= 0.3 && < 0.4,

588+ vector >= 0.7

589+

590+ ghc-options: -threaded -Wall

591+