1 files changed, 80 insertions, 0 deletions
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)