Import of source files

4 files changed, 343 insertions, 0 deletions

diff --git a/src/System/IO/Terminal/Input/Key.hs b/src/System/IO/Terminal/Input/Key.hs
new file mode 100644
index 0000000..40b52c3
--- /dev/null
+++ b/src/System/IO/Terminal/Input/Key.hs
@@ -0,0 +1,27 @@
+{-|
+Module      : System.IO.Terminal.Input.Key
+Copyright   : (c) UU, 2019
+License     : MIT
+Maintainer  : Tom Smeding
+Stability   : experimental
+Portability : POSIX, macOS, Windows
+-}
+module System.IO.Terminal.Input.Key where
+
+
+-- | A keypress. This does not attempt to model all possible keypresses
+-- that the user may enter, since not all can be recognised in the terminal
+-- anyway. The argument to 'KInvalid' contains some description of the
+-- unknown key.
+data Key = KChar Char
+         | KUp | KDown | KRight | KLeft
+         | KEnter | KDelete | KBackspace
+         | KPageDown | KPageUp | KHome | KEnd
+         | KTab
+         | KEsc
+         | KMod { kShift :: Bool
+                , kCtrl :: Bool
+                , kAlt :: Bool
+                , kKey :: Key }
+         | KInvalid String
+  deriving (Eq, Ord, Show)
diff --git a/src/System/IO/Terminal/Input/Posix.hs b/src/System/IO/Terminal/Input/Posix.hs
new file mode 100644
index 0000000..85f0268
--- /dev/null
+++ b/src/System/IO/Terminal/Input/Posix.hs
@@ -0,0 +1,187 @@
+{-|
+Module      : System.IO.Terminal.Input.Posix
+Copyright   : (c) UU, 2019
+License     : MIT
+Maintainer  : Tom Smeding
+Stability   : experimental
+Portability : POSIX, macOS
+
+Platform-specific submodule of "System.IO.Terminal.Input" that works on POSIX-like platforms.
+-}
+module System.IO.Terminal.Input.Posix
+    (withRawMode, getCharTimeout
+    ,seqParser)
+    where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Char
+import Data.Function
+import Data.List
+import Data.Maybe
+import System.IO
+import System.IO.Terminal.Input.Key
+import System.IO.Terminal.Input.SeqParser
+import System.Timeout
+
+
+-- | Run an IO-monadic computation with terminal input buffering and echo
+-- turned off.
+withRawMode :: MonadIO m => m a -> m a
+withRawMode = withNoBuffering . withNoEcho
+  where
+    withNoBuffering = with (hGetBuffering stdin `takeLeft` hSetBuffering stdin NoBuffering) (hSetBuffering stdin)
+    withNoEcho      = with (hGetEcho stdin      `takeLeft` hSetEcho stdin False)            (hSetEcho stdin)
+    with start stop act = do
+        val <- liftIO start
+        res <- act
+        _ <- liftIO $ stop val
+        return res
+    takeLeft a b = a >>= \x -> b >> return x
+
+
+peekIO :: Show a => IO a -> IO a
+-- peekIO act = act >>= \x -> print ("peekIO", x) >> return x
+peekIO = id
+
+-- | Get a character from standard input, returning Nothing if no character
+-- has appeared after the specified number of milliseconds.
+getCharTimeout :: Maybe Int -> IO (Maybe Char)
+getCharTimeout (Just timeoutms) = peekIO (timeout (1000 * timeoutms) getChar)
+getCharTimeout Nothing = peekIO (Just <$> getChar)
+
+
+-- | An ANSI escape sequence parser. Pass Nothing to the input if the time
+-- between the surrounding characters was "very long", for some definition
+-- of "very long" (a reasonable value is ~10ms). This timeout value is used
+-- to determine whether certain characters belong together in an escape
+-- sequence or are just unrelated keys.
+seqParser :: SeqParser (Maybe Char) Key
+seqParser = SeqParser $ \case
+    Nothing     -> ([], seqParser)
+    Just '\ESC' -> ([], escParser)
+    Just c      -> ([recogSingle c], seqParser)
+  where
+    escParser :: SeqParser (Maybe Char) Key
+    escParser = SeqParser $ \case
+        Nothing     -> ([KEsc], seqParser)
+        Just '\ESC' -> ([], escEscParser)
+        Just '['    -> ([], ansiParser)
+        Just c      -> ([addAlt (recogSingle c)], seqParser)
+
+    escEscParser :: SeqParser (Maybe Char) Key
+    escEscParser = SeqParser $ \case
+        Nothing     -> ([addAlt KEsc], seqParser)
+        Just '['    -> ([], fmap1st addAlt ansiParser)
+        Just '\ESC' -> ([addAlt KEsc], escParser)
+        Just c      -> ([addAlt KEsc, KChar c], seqParser)
+
+    ansiParser :: SeqParser (Maybe Char) Key
+    ansiParser = fmap recogSequence (untilRangeParser (chr 0x40, chr 0x7e) 64)
+                    `followedBy` seqParser
+      where
+        recogSequence :: Maybe [Char] -> Key
+        recogSequence mstr = fromMaybe (KInvalid (show mstr)) $ do
+            str <- mstr
+            guard (not $ null str)
+            guard (length str < 64)
+            args <- parseArguments (init str)
+            recognise args (last str)
+
+    parseArguments :: String -> Maybe [Int]
+    parseArguments = collect . groupBy ((==) `on` isDigit)
+      where
+        collect :: [String] -> Maybe [Int]
+        collect []
+            = Just []
+        collect [num] | Just val <- parseNum num
+            = Just [val]
+        collect (num:sep:args) | Just val <- parseNum num, validSep sep
+            = (val:) <$> collect args
+        collect _
+            = Nothing
+
+    parseNum :: String -> Maybe Int
+    parseNum "" = Nothing
+    parseNum str
+        | all isDigit str = Just (read str)
+        | otherwise       = Nothing
+
+    validSep :: String -> Bool
+    validSep ";" = True
+    validSep ":" = True
+    validSep _   = False
+
+    -- Terminating character is included in string
+    -- If a timeout occurs, returns Nothing
+    untilRangeParser :: (Char, Char) -> Int -> SeqParserOnce (Maybe Char) (Maybe [Char])
+    untilRangeParser (from, to) maxlen = SeqParserOnce (charHandler 0)
+      where
+        charHandler :: Int -> Maybe Char -> SeqParserOnce' (Maybe Char) (Maybe [Char])
+        charHandler _   Nothing    = SeqParserVal Nothing
+        charHandler len (Just c)
+            | len >= maxlen        = SeqParserVal Nothing
+            | from <= c && c <= to = SeqParserVal (Just [c])
+            | otherwise            = SeqParserOnce' $ \mc' -> let rec = charHandler (len + 1) mc'
+                                                              in fmap (fmap (c :)) rec
+
+    recognise :: [Int] -> Char -> Maybe Key
+    recognise args   'A' = Just (arrowMod args KUp)
+    recognise args   'B' = Just (arrowMod args KDown)
+    recognise args   'C' = Just (arrowMod args KRight)
+    recognise args   'D' = Just (arrowMod args KLeft)
+    recognise []     'H' = Just KHome
+    recognise [1,2]  'H' = Just (addShift KHome)
+    recognise [1,5]  'H' = Just (addCtrl KHome)
+    recognise [1,6]  'H' = Just (addShift $ addCtrl KHome)
+    recognise [1,9]  'H' = Just (addAlt KHome)
+    recognise [1,13] 'H' = Just (addCtrl $ addAlt KHome)
+    recognise [1,10] 'H' = Just (addShift $ addAlt KHome)
+    recognise [1,14] 'H' = Just (addCtrl $ addShift $ addAlt KHome)
+    recognise []     'F' = Just KEnd
+    recognise [1,2]  'F' = Just (addShift KEnd)
+    recognise [1,5]  'F' = Just (addCtrl KEnd)
+    recognise [1,6]  'F' = Just (addShift $ addCtrl KEnd)
+    recognise [1,9]  'F' = Just (addAlt KEnd)
+    recognise [1,13] 'F' = Just (addCtrl $ addAlt KEnd)
+    recognise [1,10] 'F' = Just (addShift $ addAlt KEnd)
+    recognise [1,14] 'F' = Just (addCtrl $ addShift $ addAlt KEnd)
+    recognise _      'Z' = Just (addShift KTab)
+    recognise []     '~' = Just KDelete
+    recognise [1]    '~' = Just KHome
+    recognise [3]    '~' = Just KDelete
+    recognise [4]    '~' = Just KEnd
+    recognise [5]    '~' = Just KPageUp
+    recognise [6]    '~' = Just KPageDown
+    recognise [n,2]  '~' = addShift <$> recognise [n] '~'
+    recognise [n,5]  '~' = addCtrl  <$> recognise [n] '~'
+    recognise _      _   = Nothing
+
+    recogSingle :: Char -> Key
+    recogSingle '\HT'  = KTab
+    recogSingle '\LF'  = KEnter
+    recogSingle '\CR'  = KEnter
+    recogSingle '\DEL' = KBackspace
+    recogSingle '\NUL' = addCtrl (KChar ' ')
+    recogSingle c
+        | ord c < 27                = addCtrl (KChar (chr $ ord 'a' - 1 + ord c))
+        | 32 <= ord c, ord c <= 126 = KChar c
+        | otherwise                 = KInvalid [c]
+
+    arrowMod :: [Int] -> Key -> Key
+    arrowMod [1,2] = addShift
+    arrowMod [1,3] = addAlt
+    arrowMod [1,5] = addCtrl
+    arrowMod [1,6] = addCtrl . addShift
+    arrowMod [1,7] = addCtrl . addAlt
+    arrowMod _     = id  -- in particular, []
+
+    addCtrl, addShift, addAlt :: Key -> Key
+    addCtrl  = kmodify (\km -> km { kCtrl  = True })
+    addShift = kmodify (\km -> km { kShift = True })
+    addAlt   = kmodify (\km -> km { kAlt   = True })
+
+    kmodify :: (Key -> Key) -> Key -> Key
+    kmodify f k@(KMod {})  = f k
+    kmodify _ (KInvalid s) = KInvalid s
+    kmodify f k            = f (KMod False False False k)
diff --git a/src/System/IO/Terminal/Input/SeqParser.hs b/src/System/IO/Terminal/Input/SeqParser.hs
new file mode 100644
index 0000000..8dfdafc
--- /dev/null
+++ b/src/System/IO/Terminal/Input/SeqParser.hs
@@ -0,0 +1,49 @@
+{-|
+Module      : System.IO.Terminal.Input.SeqParser
+Copyright   : (c) UU, 2019
+License     : MIT
+Maintainer  : Tom Smeding
+Stability   : experimental
+Portability : POSIX, macOS, Windows
+
+This module defines a coroutine-like, finite-state-machine-like type,
+'SeqParser'. Sequence parsers consume an infinite stream of values,
+producing zero or more output values after each input value read. The
+described parser is explicitly lazy to have full and explicit control over
+the amount of input necessary to produce an output value.
+-}
+module System.IO.Terminal.Input.SeqParser where
+
+
+-- | Consumes an explicitly lazy stream of @a@\'s, producing a staggered
+-- infinite stream of @b@\'s.
+newtype SeqParser a b = SeqParser (a -> ([b], SeqParser a b))
+
+-- | Consumes an explicitly lazy stream of @a@\'s, and after some nonzero
+-- number of such values, produces a @b@.
+data SeqParserOnce  a b = SeqParserOnce (a -> SeqParserOnce' a b)
+-- | A 'SeqParserOnce' that does not guarantee to consume at least one
+-- @a@.
+data SeqParserOnce' a b = SeqParserOnce' (a -> SeqParserOnce' a b) | SeqParserVal b
+
+-- | Modify the next result from the 'SeqParser'.
+fmap1st :: (b -> b) -> SeqParser a b -> SeqParser a b
+fmap1st f (SeqParser g) =
+    SeqParser $ \a -> case g a of
+                        ([], p)     -> ([], fmap1st f p)
+                        (b : bs, p) -> (f b : bs, p)
+
+instance Functor (SeqParserOnce a) where
+    fmap f (SeqParserOnce g) = SeqParserOnce (fmap f . g)
+
+instance Functor (SeqParserOnce' a) where
+    fmap f (SeqParserVal x)   = SeqParserVal (f x)
+    fmap f (SeqParserOnce' g) = SeqParserOnce' (fmap f . g)
+
+-- | After the 'SeqParserOnce' is done, continue processing input with the
+-- 'SeqParser'.
+followedBy :: SeqParserOnce a b -> SeqParser a b -> SeqParser a b
+followedBy (SeqParserOnce g) p =
+    SeqParser $ \a -> case g a of
+        SeqParserVal b    -> ([b], p)
+        SeqParserOnce' g' -> ([], SeqParserOnce g' `followedBy` p)
diff --git a/src/System/IO/Terminal/Input/Windows.hs b/src/System/IO/Terminal/Input/Windows.hs
new file mode 100644
index 0000000..0ac4122
--- /dev/null
+++ b/src/System/IO/Terminal/Input/Windows.hs
@@ -0,0 +1,80 @@
+{-|
+Module      : System.IO.Terminal.Input.Windows
+Copyright   : (c) UU, 2019
+License     : MIT
+Maintainer  : Tom Smeding
+Stability   : experimental
+Portability : Windows
+
+Platform-specific submodule of "System.IO.Terminal.Input" that works on Windows.
+-}
+module System.IO.Terminal.Input.Windows
+    (withRawMode, getCharTimeout
+    ,seqParser)
+    where
+
+import Control.Monad.IO.Class
+import Data.Char
+import System.IO.HiddenChar
+import System.IO.Terminal.Input.Key
+import System.IO.Terminal.Input.SeqParser
+
+
+-- | Run an IO-monadic computation with terminal input buffering and echo
+-- turned off.
+--
+-- Note: on Windows this is currently nonfunctional.
+withRawMode :: MonadIO m => m a -> m a
+withRawMode = id
+
+
+peekIO :: Show a => IO a -> IO a
+-- peekIO act = act >>= \x -> print ("peekIO", x) >> return x
+peekIO = id
+
+-- | Get a character from standard input, returning Nothing if no character
+-- has appeared after the specified number of milliseconds.
+--
+-- Note: on Windows the timeout is currently ineffective.
+getCharTimeout :: Maybe Int -> IO (Maybe Char)
+getCharTimeout _ = peekIO (Just <$> getHiddenChar)
+
+
+-- | A Windows conio control sequence parser. Pass Nothing to the input if
+-- the time between the surrounding characters was "very long", for some
+-- definition of "very long" (a reasonable value is ~10ms). This timeout
+-- value is used to determine whether certain characters belong together in
+-- an escape sequence or are just unrelated keys.
+seqParser :: SeqParser (Maybe Char) Key
+seqParser = SeqParser $ \case
+    Nothing     -> ([], seqParser)
+    Just '\224' -> ([], escParser)
+    Just c      -> ([recogSingle c], seqParser)
+  where
+    escParser :: SeqParser (Maybe Char) Key
+    escParser = SeqParser $ \case
+        Nothing  -> ([KInvalid "timeout"], seqParser)
+        Just 'H' -> ([KUp], seqParser)
+        Just 'P' -> ([KDown], seqParser)
+        Just 'M' -> ([KRight], seqParser)
+        Just 'K' -> ([KLeft], seqParser)
+        Just c   -> ([KInvalid ['\224', c]], seqParser)
+
+    recogSingle :: Char -> Key
+    recogSingle '\ESC' = KEsc
+    recogSingle '\HT'  = KTab
+    recogSingle '\LF'  = KEnter
+    recogSingle '\CR'  = KEnter
+    recogSingle '\BS'  = KBackspace
+    recogSingle '\NUL' = addCtrl (KChar ' ')
+    recogSingle c
+        | ord c < 27                = addCtrl (KChar (chr $ ord 'a' - 1 + ord c))
+        | 32 <= ord c, ord c <= 126 = KChar c
+        | otherwise                 = KInvalid [c]
+
+    addCtrl :: Key -> Key
+    addCtrl  = kmodify (\km -> km { kCtrl  = True })
+
+    kmodify :: (Key -> Key) -> Key -> Key
+    kmodify f k@(KMod {}) = f k
+    kmodify f k           = f (KMod False False False k)