Add some windows hack for getChar

keydemo.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE CPP                      #-}
+
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+{-# LANGUAGE ForeignFunctionInterface #-}
+#endif
+
+import           Control.Monad   (forever)
+import qualified System.IO       as IO
+
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+import           Data.Char       (chr)
+import           Foreign.C.Types (CInt (..))
+#endif
+
+data Key
+    = CharKey Char
+    | Enter
+    | Backspace
+    | LeftArrow
+    | RightArrow
+    | DownArrow
+    | UpArrow
+    | PageUp
+    | PageDown
+    | Kill
+    | UnknownKey String
+    deriving (Eq, Show)
+
+initialize :: IO ()
+initialize = IO.hSetBuffering IO.stdin IO.NoBuffering
+
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+foreign import ccall unsafe "conio.h getch" win_getch :: IO CInt
+#endif
+
+getKey :: IO Key
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+getKey = do
+    c0 <- fromEnum <$> win_getch
+    if c0 == 0x00 || c0 == 0xE0 then do
+        c1 <- chr . fromEnum <$> win_getch
+        case c1 of
+            'M' -> return RightArrow
+            'K' -> return LeftArrow
+            'P' -> return DownArrow
+            'H' -> return UpArrow
+            'Q' -> return PageDown
+            'I' -> return PageUp
+            _   -> return $ UnknownKey [chr c0, c1]
+    else do
+        case chr c0 of
+            '\b'   -> return Backspace
+            '\r'   -> return Enter
+            '\ETX' -> return Kill
+            x      -> return $ CharKey x
+  where
+#else
+getKey = do
+    c0 <- IO.getChar
+    case c0 of
+        '\n'   -> return Enter
+        '\DEL' -> return Backspace
+        '\ESC' -> do
+            c1 <- IO.getChar
+            case c1 of
+                '[' -> do
+                    c2 <- IO.getChar
+                    case c2 of
+                        'C' -> return RightArrow
+                        'D' -> return LeftArrow
+                        'B' -> return DownArrow
+                        'A' -> return UpArrow
+                        '6' -> return PageDown
+                        '5' -> return PageUp
+                        unknown  -> return $ UnknownKey [c0, c1, c2]
+                _ -> return $ UnknownKey [c0, c1]
+        _ -> return $ CharKey c0
+#endif
+
+
+main :: IO ()
+main = forever $ do
+    putStrLn "Press a key:"
+    k <- getKey
+    putStrLn $ "You pressed: " ++ show k

patat.cabal

@@ -66,6 +66,7 @@ Executable patat
     Data.Aeson.TH.Extended
     Data.Data.Extended
     Patat.AutoAdvance
+    Patat.GetKey
     Patat.Images
     Patat.Images.Internal
     Patat.Images.W3m

src/Main.hs

@@ -16,6 +16,7 @@ import           Data.Monoid                  (mempty, (<>))
 import           Data.Time                    (UTCTime)
 import           Data.Version                 (showVersion)
 import qualified Options.Applicative          as OA
+import qualified Patat.GetKey                 as GetKey
 import           Patat.AutoAdvance
 import qualified Patat.Images                 as Images
 import           Patat.Presentation
@@ -137,7 +138,7 @@ main = do
   where
     interactiveLoop :: Options -> Maybe Images.Handle -> Presentation -> IO ()
     interactiveLoop options images pres0 = (`finally` cleanup) $ do
-        IO.hSetBuffering IO.stdin IO.NoBuffering
+        GetKey.initialize
         Ansi.hideCursor
 
         -- Spawn the initial channel that gives us commands based on user input.

src/Patat/GetKey.hs

@@ -0,0 +1,104 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP                      #-}
+
+
+--------------------------------------------------------------------------------
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+{-# LANGUAGE ForeignFunctionInterface #-}
+#endif
+
+
+--------------------------------------------------------------------------------
+module Patat.GetKey
+    ( Key (..)
+    , initialize
+    , getKey
+    ) where
+
+
+--------------------------------------------------------------------------------
+import qualified System.IO       as IO
+
+
+--------------------------------------------------------------------------------
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+import           Data.Char       (chr)
+import           Foreign.C.Types (CInt (..))
+#endif
+
+
+--------------------------------------------------------------------------------
+data Key
+    = CharKey Char
+    | Enter
+    | Backspace
+    | LeftArrow
+    | RightArrow
+    | DownArrow
+    | UpArrow
+    | PageUp
+    | PageDown
+    | Kill
+    | UnknownKey String
+    deriving (Eq, Show)
+
+
+--------------------------------------------------------------------------------
+initialize :: IO ()
+initialize = IO.hSetBuffering IO.stdin IO.NoBuffering
+
+
+--------------------------------------------------------------------------------
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+foreign import ccall unsafe "conio.h getch" win_getch :: IO CInt
+#endif
+
+
+--------------------------------------------------------------------------------
+getKey :: IO Key
+
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+
+getKey = do
+    c0 <- fromEnum <$> win_getch
+    if c0 == 0x00 || c0 == 0xE0 then do
+        c1 <- chr . fromEnum <$> win_getch
+        case c1 of
+            'M' -> return RightArrow
+            'K' -> return LeftArrow
+            'P' -> return DownArrow
+            'H' -> return UpArrow
+            'Q' -> return PageDown
+            'I' -> return PageUp
+            _   -> return $ UnknownKey [chr c0, c1]
+    else do
+        case chr c0 of
+            '\b'   -> return Backspace
+            '\r'   -> return Enter
+            '\ETX' -> return Kill
+            x      -> return $ CharKey x
+
+#else
+
+getKey = do
+    c0 <- IO.getChar
+    case c0 of
+        '\n'   -> return Enter
+        '\DEL' -> return Backspace
+        '\ESC' -> do
+            c1 <- IO.getChar
+            case c1 of
+                '[' -> do
+                    c2 <- IO.getChar
+                    case c2 of
+                        'C' -> return RightArrow
+                        'D' -> return LeftArrow
+                        'B' -> return DownArrow
+                        'A' -> return UpArrow
+                        '6' -> return PageDown
+                        '5' -> return PageUp
+                        unknown  -> return $ UnknownKey [c0, c1, c2]
+                _ -> return $ UnknownKey [c0, c1]
+        _ -> return $ CharKey c0
+
+#endif

src/Patat/Presentation/Interactive.hs

@@ -13,6 +13,7 @@ module Patat.Presentation.Interactive
 
 
 --------------------------------------------------------------------------------
+import qualified Patat.GetKey                as GetKey
 import           Patat.Presentation.Internal
 import           Patat.Presentation.Read
 
@@ -27,46 +28,35 @@ data PresentationCommand
     | First
     | Last
     | Reload
-    | UnknownCommand String
+    | UnknownCommand GetKey.Key
 
 
 --------------------------------------------------------------------------------
 readPresentationCommand :: IO PresentationCommand
 readPresentationCommand = do
-    k <- readKey
+    k <- GetKey.getKey
     case k of
-        "q"      -> return Exit
-        "\n"     -> return Forward
-        "\DEL"   -> return Backward
-        "h"      -> return Backward
-        "j"      -> return SkipForward
-        "k"      -> return SkipBackward
-        "l"      -> return Forward
+        GetKey.Kill        -> return Exit
+        GetKey.CharKey 'q' -> return Exit
+        GetKey.Enter       -> return Forward
+        GetKey.Backspace   -> return Backward
+        GetKey.CharKey 'h' -> return Backward
+        GetKey.CharKey 'j' -> return SkipForward
+        GetKey.CharKey 'k' -> return SkipBackward
+        GetKey.CharKey 'l' -> return Forward
         -- Arrow keys
-        "\ESC[C" -> return Forward
-        "\ESC[D" -> return Backward
-        "\ESC[B" -> return SkipForward
-        "\ESC[A" -> return SkipBackward
+        GetKey.RightArrow  -> return Forward
+        GetKey.LeftArrow   -> return Backward
+        GetKey.DownArrow   -> return SkipForward
+        GetKey.UpArrow     -> return SkipBackward
         -- PageUp and PageDown
-        "\ESC[6" -> return Forward
-        "\ESC[5" -> return Backward
-        "0"      -> return First
-        "G"      -> return Last
-        "r"      -> return Reload
-        _        -> return (UnknownCommand k)
-  where
-    readKey :: IO String
-    readKey = do
-        c0 <- getChar
-        case c0 of
-            '\ESC' -> do
-                c1 <- getChar
-                case c1 of
-                    '[' -> do
-                        c2 <- getChar
-                        return [c0, c1, c2]
-                    _ -> return [c0, c1]
-            _ -> return [c0]
+        GetKey.PageDown    -> return Forward
+        GetKey.PageUp      -> return Backward
+        GetKey.CharKey '0' -> return First
+        GetKey.CharKey 'G' -> return Last
+        GetKey.CharKey 'r' -> return Reload
+        GetKey.CharKey    _ -> return (UnknownCommand k)
+        GetKey.UnknownKey _ -> return (UnknownCommand k)
 
 
 --------------------------------------------------------------------------------