{-# LINE 1 "System/Console/Haskeline/Backend/Posix.hsc" #-}
{-# LANGUAGE CApiFFI #-}

module System.Console.Haskeline.Backend.Posix (
                        withPosixGetEvent,
                        posixLayouts,
                        tryGetLayouts,
                        PosixT,
                        Handles(),
                        ehIn,
                        ehOut,
                        mapLines,
                        stdinTTYHandles,
                        ttyHandles,
                        explicitTTYHandles,
                        posixRunTerm,
                        fileRunTerm
                 ) where

import Foreign
import Foreign.C.Types
import qualified Data.Map as Map
import System.Posix.Terminal hiding (Interrupt)
import Control.Exception (throwTo)
import Control.Monad
import Control.Monad.Catch (MonadMask, handle, finally)
import Control.Concurrent.STM
import Control.Concurrent hiding (throwTo)
import Data.Maybe (catMaybes)
import System.Posix.Signals.Exts
import System.Posix.Types(Fd(..))
import Data.Foldable (foldl')
import System.IO
import System.Environment

import System.Console.Haskeline.Monads
import System.Console.Haskeline.Key
import System.Console.Haskeline.Term as Term
import System.Console.Haskeline.Prefs

import System.Console.Haskeline.Backend.Posix.Encoder

import GHC.IO.FD (fdFD)
import Data.Typeable (cast)
import System.IO.Error
import GHC.IO.Exception
import GHC.IO.Handle.Types hiding (getState)
import GHC.IO.Handle.Internals
import System.Posix.Internals (FD)


{-# LINE 53 "System/Console/Haskeline/Backend/Posix.hsc" #-}




-----------------------------------------------
-- Input/output handles
data Handles = Handles {Handles -> ExternalHandle
hIn, Handles -> ExternalHandle
hOut :: ExternalHandle
                        , Handles -> IO ()
closeHandles :: IO ()}

ehIn, ehOut :: Handles -> Handle
ehIn :: Handles -> Handle
ehIn = ExternalHandle -> Handle
eH (ExternalHandle -> Handle)
-> (Handles -> ExternalHandle) -> Handles -> Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handles -> ExternalHandle
hIn
ehOut :: Handles -> Handle
ehOut = ExternalHandle -> Handle
eH (ExternalHandle -> Handle)
-> (Handles -> ExternalHandle) -> Handles -> Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handles -> ExternalHandle
hOut

-------------------
-- Window size


{-# LINE 73 "System/Console/Haskeline/Backend/Posix.hsc" #-}
foreign import capi "sys/ioctl.h ioctl" ioctl :: FD -> CULong -> Ptr a -> IO CInt

posixLayouts :: Handles -> [IO (Maybe Layout)]
posixLayouts :: Handles -> [IO (Maybe Layout)]
posixLayouts Handles
h = [Handle -> IO (Maybe Layout)
ioctlLayout (Handle -> IO (Maybe Layout)) -> Handle -> IO (Maybe Layout)
forall a b. (a -> b) -> a -> b
$ Handles -> Handle
ehOut Handles
h, IO (Maybe Layout)
envLayout]

ioctlLayout :: Handle -> IO (Maybe Layout)
ioctlLayout :: Handle -> IO (Maybe Layout)
ioctlLayout Handle
h = Int -> (Ptr Any -> IO (Maybe Layout)) -> IO (Maybe Layout)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes ((Int
8)) ((Ptr Any -> IO (Maybe Layout)) -> IO (Maybe Layout))
-> (Ptr Any -> IO (Maybe Layout)) -> IO (Maybe Layout)
forall a b. (a -> b) -> a -> b
$ \Ptr Any
ws -> do
{-# LINE 80 "System/Console/Haskeline/Backend/Posix.hsc" #-}
                CInt
fd <- Handle -> IO CInt
unsafeHandleToFD Handle
h
                CInt
ret <- CInt -> CULong -> Ptr Any -> IO CInt
forall a. CInt -> CULong -> Ptr a -> IO CInt
ioctl CInt
fd (CULong
21523) Ptr Any
ws
{-# LINE 82 "System/Console/Haskeline/Backend/Posix.hsc" #-}
                CUShort
rows :: CUShort <- ((\Ptr Any
hsc_ptr -> Ptr Any -> Int -> IO CUShort
forall b. Ptr b -> Int -> IO CUShort
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
hsc_ptr Int
0)) Ptr Any
ws
{-# LINE 83 "System/Console/Haskeline/Backend/Posix.hsc" #-}
                CUShort
cols :: CUShort <- ((\Ptr Any
hsc_ptr -> Ptr Any -> Int -> IO CUShort
forall b. Ptr b -> Int -> IO CUShort
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
hsc_ptr Int
2)) Ptr Any
ws
{-# LINE 84 "System/Console/Haskeline/Backend/Posix.hsc" #-}
                if CInt
ret CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
>= CInt
0
                    then Maybe Layout -> IO (Maybe Layout)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Layout -> IO (Maybe Layout))
-> Maybe Layout -> IO (Maybe Layout)
forall a b. (a -> b) -> a -> b
$ Layout -> Maybe Layout
forall a. a -> Maybe a
Just Layout {height :: Int
height=CUShort -> Int
forall a. Enum a => a -> Int
fromEnum CUShort
rows,width :: Int
width=CUShort -> Int
forall a. Enum a => a -> Int
fromEnum CUShort
cols}
                    else Maybe Layout -> IO (Maybe Layout)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Layout
forall a. Maybe a
Nothing


{-# LINE 89 "System/Console/Haskeline/Backend/Posix.hsc" #-}

unsafeHandleToFD :: Handle -> IO FD
unsafeHandleToFD :: Handle -> IO CInt
unsafeHandleToFD Handle
h =
  String -> Handle -> (Handle__ -> IO CInt) -> IO CInt
forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
withHandle_ String
"unsafeHandleToFd" Handle
h ((Handle__ -> IO CInt) -> IO CInt)
-> (Handle__ -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Handle__{haDevice :: ()
haDevice=dev
dev} -> do
  case dev -> Maybe FD
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast dev
dev of
    Maybe FD
Nothing -> IOException -> IO CInt
forall a. IOException -> IO a
ioError (IOException -> String -> IOException
ioeSetErrorString (IOErrorType
-> String -> Maybe Handle -> Maybe String -> IOException
mkIOError IOErrorType
IllegalOperation
                                           String
"unsafeHandleToFd" (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h) Maybe String
forall a. Maybe a
Nothing)
                        String
"handle is not a file descriptor")
    Just FD
fd -> CInt -> IO CInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FD -> CInt
fdFD FD
fd)

envLayout :: IO (Maybe Layout)
envLayout :: IO (Maybe Layout)
envLayout = (IOException -> IO (Maybe Layout))
-> IO (Maybe Layout) -> IO (Maybe Layout)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOException
_::IOException) -> Maybe Layout -> IO (Maybe Layout)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Layout
forall a. Maybe a
Nothing) (IO (Maybe Layout) -> IO (Maybe Layout))
-> IO (Maybe Layout) -> IO (Maybe Layout)
forall a b. (a -> b) -> a -> b
$ do
    -- note the handle catches both undefined envs and bad reads
    String
r <- String -> IO String
getEnv String
"ROWS"
    String
c <- String -> IO String
getEnv String
"COLUMNS"
    Maybe Layout -> IO (Maybe Layout)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Layout -> IO (Maybe Layout))
-> Maybe Layout -> IO (Maybe Layout)
forall a b. (a -> b) -> a -> b
$ Layout -> Maybe Layout
forall a. a -> Maybe a
Just (Layout -> Maybe Layout) -> Layout -> Maybe Layout
forall a b. (a -> b) -> a -> b
$ Layout {height :: Int
height=String -> Int
forall a. Read a => String -> a
read String
r,width :: Int
width=String -> Int
forall a. Read a => String -> a
read String
c}

tryGetLayouts :: [IO (Maybe Layout)] -> IO Layout
tryGetLayouts :: [IO (Maybe Layout)] -> IO Layout
tryGetLayouts [] = Layout -> IO Layout
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Layout {height :: Int
height=Int
24,width :: Int
width=Int
80}
tryGetLayouts (IO (Maybe Layout)
f:[IO (Maybe Layout)]
fs) = do
    Maybe Layout
ml <- IO (Maybe Layout)
f
    case Maybe Layout
ml of
        Just Layout
l | Layout -> Int
height Layout
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& Layout -> Int
width Layout
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 -> Layout -> IO Layout
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Layout
l
        Maybe Layout
_ -> [IO (Maybe Layout)] -> IO Layout
tryGetLayouts [IO (Maybe Layout)]
fs


--------------------
-- Key sequences

getKeySequences :: (MonadIO m, MonadReader Prefs m)
        => Handle -> [(String,Key)] -> m (TreeMap Char Key)
getKeySequences :: forall (m :: * -> *).
(MonadIO m, MonadReader Prefs m) =>
Handle -> [(String, Key)] -> m (TreeMap Char Key)
getKeySequences Handle
h [(String, Key)]
tinfos = do
    [(String, Key)]
sttys <- IO [(String, Key)] -> m [(String, Key)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(String, Key)] -> m [(String, Key)])
-> IO [(String, Key)] -> m [(String, Key)]
forall a b. (a -> b) -> a -> b
$ Handle -> IO [(String, Key)]
sttyKeys Handle
h
    [(String, Key)]
customKeySeqs <- m [(String, Key)]
getCustomKeySeqs
    -- note ++ acts as a union; so the below favors sttys over tinfos
    TreeMap Char Key -> m (TreeMap Char Key)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeMap Char Key -> m (TreeMap Char Key))
-> TreeMap Char Key -> m (TreeMap Char Key)
forall a b. (a -> b) -> a -> b
$ [(String, Key)] -> TreeMap Char Key
forall a b. Ord a => [([a], b)] -> TreeMap a b
listToTree
        ([(String, Key)] -> TreeMap Char Key)
-> [(String, Key)] -> TreeMap Char Key
forall a b. (a -> b) -> a -> b
$ [(String, Key)]
ansiKeys [(String, Key)] -> [(String, Key)] -> [(String, Key)]
forall a. [a] -> [a] -> [a]
++ [(String, Key)]
tinfos [(String, Key)] -> [(String, Key)] -> [(String, Key)]
forall a. [a] -> [a] -> [a]
++ [(String, Key)]
sttys [(String, Key)] -> [(String, Key)] -> [(String, Key)]
forall a. [a] -> [a] -> [a]
++ [(String, Key)]
customKeySeqs
  where
    getCustomKeySeqs :: m [(String, Key)]
getCustomKeySeqs = do
        [(Maybe String, String, Key)]
kseqs <- (Prefs -> [(Maybe String, String, Key)])
-> m [(Maybe String, String, Key)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Prefs -> [(Maybe String, String, Key)]
customKeySequences
        String
termName <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ (IOException -> IO String) -> IO String -> IO String
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOException
_::IOException) -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"") (String -> IO String
getEnv String
"TERM")
        let isThisTerm :: Maybe String -> Bool
isThisTerm = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
termName)
        [(String, Key)] -> m [(String, Key)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Key)] -> m [(String, Key)])
-> [(String, Key)] -> m [(String, Key)]
forall a b. (a -> b) -> a -> b
$ ((Maybe String, String, Key) -> (String, Key))
-> [(Maybe String, String, Key)] -> [(String, Key)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe String
_,String
cs,Key
k) ->(String
cs,Key
k))
            ([(Maybe String, String, Key)] -> [(String, Key)])
-> [(Maybe String, String, Key)] -> [(String, Key)]
forall a b. (a -> b) -> a -> b
$ ((Maybe String, String, Key) -> Bool)
-> [(Maybe String, String, Key)] -> [(Maybe String, String, Key)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Maybe String
kseqs',String
_,Key
_) -> Maybe String -> Bool
isThisTerm Maybe String
kseqs')
            ([(Maybe String, String, Key)] -> [(Maybe String, String, Key)])
-> [(Maybe String, String, Key)] -> [(Maybe String, String, Key)]
forall a b. (a -> b) -> a -> b
$ [(Maybe String, String, Key)]
kseqs


ansiKeys :: [(String, Key)]
ansiKeys :: [(String, Key)]
ansiKeys = [(String
"\ESC[D",  BaseKey -> Key
simpleKey BaseKey
LeftKey)
            ,(String
"\ESC[C",  BaseKey -> Key
simpleKey BaseKey
RightKey)
            ,(String
"\ESC[A",  BaseKey -> Key
simpleKey BaseKey
UpKey)
            ,(String
"\ESC[B",  BaseKey -> Key
simpleKey BaseKey
DownKey)
            ,(String
"\b",      BaseKey -> Key
simpleKey BaseKey
Backspace)
            -- ctrl-left/right aren't a standard
            -- part of terminfo, but enough people have complained
            -- that I've decided to hard-code them in.
            -- (Note they will be overridden by terminfo or .haskeline.)
            -- These appear to be the most common bindings:
            -- xterm:
            ,(String
"\ESC[1;5D", Key -> Key
ctrlKey (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
LeftKey)
            ,(String
"\ESC[1;5C", Key -> Key
ctrlKey (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
RightKey)
            -- Terminal.app:
            ,(String
"\ESC[5D", Key -> Key
ctrlKey (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
LeftKey)
            ,(String
"\ESC[5C", Key -> Key
ctrlKey (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
RightKey)
            -- rxvt: (Note: these will be superseded by e.g. xterm-color,
            -- which uses them as regular arrow keys.)
            ,(String
"\ESC[OD", Key -> Key
ctrlKey (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
LeftKey)
            ,(String
"\ESC[OC", Key -> Key
ctrlKey (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
RightKey)
            ]


sttyKeys :: Handle -> IO [(String, Key)]
sttyKeys :: Handle -> IO [(String, Key)]
sttyKeys Handle
h = do
    CInt
fd <- Handle -> IO CInt
unsafeHandleToFD Handle
h
    TerminalAttributes
attrs <- Fd -> IO TerminalAttributes
getTerminalAttributes (CInt -> Fd
Fd CInt
fd)
    let getStty :: (ControlCharacter, b) -> Maybe (String, b)
getStty (ControlCharacter
k,b
c) = do {Char
str <- TerminalAttributes -> ControlCharacter -> Maybe Char
controlChar TerminalAttributes
attrs ControlCharacter
k; (String, b) -> Maybe (String, b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char
str],b
c)}
    [(String, Key)] -> IO [(String, Key)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Key)] -> IO [(String, Key)])
-> [(String, Key)] -> IO [(String, Key)]
forall a b. (a -> b) -> a -> b
$ [Maybe (String, Key)] -> [(String, Key)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (String, Key)] -> [(String, Key)])
-> [Maybe (String, Key)] -> [(String, Key)]
forall a b. (a -> b) -> a -> b
$ ((ControlCharacter, Key) -> Maybe (String, Key))
-> [(ControlCharacter, Key)] -> [Maybe (String, Key)]
forall a b. (a -> b) -> [a] -> [b]
map (ControlCharacter, Key) -> Maybe (String, Key)
forall {b}. (ControlCharacter, b) -> Maybe (String, b)
getStty [(ControlCharacter
Erase,BaseKey -> Key
simpleKey BaseKey
Backspace),(ControlCharacter
Kill,BaseKey -> Key
simpleKey BaseKey
KillLine)]

newtype TreeMap a b = TreeMap (Map.Map a (Maybe b, TreeMap a b))
                        deriving Int -> TreeMap a b -> ShowS
[TreeMap a b] -> ShowS
TreeMap a b -> String
(Int -> TreeMap a b -> ShowS)
-> (TreeMap a b -> String)
-> ([TreeMap a b] -> ShowS)
-> Show (TreeMap a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> TreeMap a b -> ShowS
forall a b. (Show a, Show b) => [TreeMap a b] -> ShowS
forall a b. (Show a, Show b) => TreeMap a b -> String
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> TreeMap a b -> ShowS
showsPrec :: Int -> TreeMap a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => TreeMap a b -> String
show :: TreeMap a b -> String
$cshowList :: forall a b. (Show a, Show b) => [TreeMap a b] -> ShowS
showList :: [TreeMap a b] -> ShowS
Show

emptyTreeMap :: TreeMap a b
emptyTreeMap :: forall a b. TreeMap a b
emptyTreeMap = Map a (Maybe b, TreeMap a b) -> TreeMap a b
forall a b. Map a (Maybe b, TreeMap a b) -> TreeMap a b
TreeMap Map a (Maybe b, TreeMap a b)
forall k a. Map k a
Map.empty

insertIntoTree :: Ord a => ([a], b) -> TreeMap a b -> TreeMap a b
insertIntoTree :: forall a b. Ord a => ([a], b) -> TreeMap a b -> TreeMap a b
insertIntoTree ([],b
_) TreeMap a b
_ = String -> TreeMap a b
forall a. HasCallStack => String -> a
error String
"Can't insert empty list into a treemap!"
insertIntoTree ((a
c:[a]
cs),b
k) (TreeMap Map a (Maybe b, TreeMap a b)
m) = Map a (Maybe b, TreeMap a b) -> TreeMap a b
forall a b. Map a (Maybe b, TreeMap a b) -> TreeMap a b
TreeMap ((Maybe (Maybe b, TreeMap a b) -> Maybe (Maybe b, TreeMap a b))
-> a
-> Map a (Maybe b, TreeMap a b)
-> Map a (Maybe b, TreeMap a b)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Maybe b, TreeMap a b) -> Maybe (Maybe b, TreeMap a b)
f a
c Map a (Maybe b, TreeMap a b)
m)
    where
        alterSubtree :: TreeMap a b -> TreeMap a b
alterSubtree = ([a], b) -> TreeMap a b -> TreeMap a b
forall a b. Ord a => ([a], b) -> TreeMap a b -> TreeMap a b
insertIntoTree ([a]
cs,b
k)
        f :: Maybe (Maybe b, TreeMap a b) -> Maybe (Maybe b, TreeMap a b)
f Maybe (Maybe b, TreeMap a b)
Nothing = (Maybe b, TreeMap a b) -> Maybe (Maybe b, TreeMap a b)
forall a. a -> Maybe a
Just ((Maybe b, TreeMap a b) -> Maybe (Maybe b, TreeMap a b))
-> (Maybe b, TreeMap a b) -> Maybe (Maybe b, TreeMap a b)
forall a b. (a -> b) -> a -> b
$ if [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
cs
                            then (b -> Maybe b
forall a. a -> Maybe a
Just b
k, TreeMap a b
forall a b. TreeMap a b
emptyTreeMap)
                            else (Maybe b
forall a. Maybe a
Nothing, TreeMap a b -> TreeMap a b
alterSubtree TreeMap a b
forall a b. TreeMap a b
emptyTreeMap)
        f (Just (Maybe b
y,TreeMap a b
t)) = (Maybe b, TreeMap a b) -> Maybe (Maybe b, TreeMap a b)
forall a. a -> Maybe a
Just ((Maybe b, TreeMap a b) -> Maybe (Maybe b, TreeMap a b))
-> (Maybe b, TreeMap a b) -> Maybe (Maybe b, TreeMap a b)
forall a b. (a -> b) -> a -> b
$ if [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
cs
                                    then (b -> Maybe b
forall a. a -> Maybe a
Just b
k, TreeMap a b
t)
                                    else (Maybe b
y, TreeMap a b -> TreeMap a b
alterSubtree TreeMap a b
t)

listToTree :: Ord a => [([a],b)] -> TreeMap a b
listToTree :: forall a b. Ord a => [([a], b)] -> TreeMap a b
listToTree = (TreeMap a b -> ([a], b) -> TreeMap a b)
-> TreeMap a b -> [([a], b)] -> TreeMap a b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((([a], b) -> TreeMap a b -> TreeMap a b)
-> TreeMap a b -> ([a], b) -> TreeMap a b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([a], b) -> TreeMap a b -> TreeMap a b
forall a b. Ord a => ([a], b) -> TreeMap a b -> TreeMap a b
insertIntoTree) TreeMap a b
forall a b. TreeMap a b
emptyTreeMap

-- for debugging '
mapLines :: (Show a, Show b) => TreeMap a b -> [String]
mapLines :: forall a b. (Show a, Show b) => TreeMap a b -> [String]
mapLines (TreeMap Map a (Maybe b, TreeMap a b)
m) = let
    m2 :: Map a [String]
m2 = ((Maybe b, TreeMap a b) -> [String])
-> Map a (Maybe b, TreeMap a b) -> Map a [String]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(Maybe b
k,TreeMap a b
t) -> Maybe b -> String
forall a. Show a => a -> String
show Maybe b
k String -> [String] -> [String]
forall a. a -> [a] -> [a]
: TreeMap a b -> [String]
forall a b. (Show a, Show b) => TreeMap a b -> [String]
mapLines TreeMap a b
t) Map a (Maybe b, TreeMap a b)
m
    in ((a, [String]) -> [String]) -> [(a, [String])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(a
k,[String]
ls) -> a -> String
forall a. Show a => a -> String
show a
k String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) [String]
ls) ([(a, [String])] -> [String]) -> [(a, [String])] -> [String]
forall a b. (a -> b) -> a -> b
$ Map a [String] -> [(a, [String])]
forall k a. Map k a -> [(k, a)]
Map.toList Map a [String]
m2

lexKeys :: TreeMap Char Key -> [Char] -> [Key]
lexKeys :: TreeMap Char Key -> String -> [Key]
lexKeys TreeMap Char Key
_ [] = []
lexKeys TreeMap Char Key
baseMap String
cs
    | Just (Key
k,String
ds) <- TreeMap Char Key -> String -> Maybe (Key, String)
lookupChars TreeMap Char Key
baseMap String
cs
            = Key
k Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: TreeMap Char Key -> String -> [Key]
lexKeys TreeMap Char Key
baseMap String
ds
lexKeys TreeMap Char Key
baseMap (Char
'\ESC':String
cs)
-- TODO: what's the right thing ' to do here?
    | Key
k:[Key]
ks <- TreeMap Char Key -> String -> [Key]
lexKeys TreeMap Char Key
baseMap String
cs
            = Key -> Key
metaKey Key
k Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: [Key]
ks
lexKeys TreeMap Char Key
baseMap (Char
c:String
cs) = Char -> Key
simpleChar Char
c Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: TreeMap Char Key -> String -> [Key]
lexKeys TreeMap Char Key
baseMap String
cs

-- | Walk @cs@ through the tree, returning the /longest/ key found along
-- the path together with whatever bytes follow it.
--
-- If a longer match is attempted but doesn't pan out (the next byte
-- isn't in the deeper subtree), we fall back to the most recent shorter
-- key we passed.  This avoids the well-known sharp edge where input
-- like @\\ESC[AC@ — with @\\ESC[A@ registered (up-arrow) and the @A@
-- node having children that don't include @C@ — would previously be
-- reported as no match at all, instead of @up-arrow + 'C'@.
--
-- 'Nothing' is returned only when no key is reached anywhere along the
-- walk.
lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key, [Char])
lookupChars :: TreeMap Char Key -> String -> Maybe (Key, String)
lookupChars TreeMap Char Key
_    [] = Maybe (Key, String)
forall a. Maybe a
Nothing
lookupChars TreeMap Char Key
tree String
cs = Maybe (Key, String)
-> TreeMap Char Key -> String -> Maybe (Key, String)
forall {k} {b}.
Ord k =>
Maybe (b, [k]) -> TreeMap k b -> [k] -> Maybe (b, [k])
go Maybe (Key, String)
forall a. Maybe a
Nothing TreeMap Char Key
tree String
cs
  where
    -- 'best' holds the longest committed match so far (or Nothing if
    -- we haven't passed a key node yet).  When the next byte doesn't
    -- extend the path we return 'best'.
    go :: Maybe (b, [k]) -> TreeMap k b -> [k] -> Maybe (b, [k])
go Maybe (b, [k])
best (TreeMap Map k (Maybe b, TreeMap k b)
m) (k
c:[k]
cs') = case k -> Map k (Maybe b, TreeMap k b) -> Maybe (Maybe b, TreeMap k b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
c Map k (Maybe b, TreeMap k b)
m of
        Maybe (Maybe b, TreeMap k b)
Nothing          -> Maybe (b, [k])
best
        Just (Maybe b
mKey, TreeMap k b
sub) ->
            let best' :: Maybe (b, [k])
best' = Maybe (b, [k])
-> (b -> Maybe (b, [k])) -> Maybe b -> Maybe (b, [k])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (b, [k])
best (\b
k -> (b, [k]) -> Maybe (b, [k])
forall a. a -> Maybe a
Just (b
k, [k]
cs')) Maybe b
mKey
            in case [k]
cs' of
                k
_:[k]
_ -> Maybe (b, [k]) -> TreeMap k b -> [k] -> Maybe (b, [k])
go Maybe (b, [k])
best' TreeMap k b
sub [k]
cs'
                []  -> Maybe (b, [k])
best'
    go Maybe (b, [k])
best TreeMap k b
_ [] = Maybe (b, [k])
best  -- unreachable: top-level [] handled above

-- | Greedily peel complete keys off the front of @cs@.  Returns the
-- decoded keys (in forward order) and the leftover bytes that didn't
-- (yet) form a complete tree match.
peelCompleteKeys :: TreeMap Char Key -> [Char] -> ([Key], [Char])
peelCompleteKeys :: TreeMap Char Key -> String -> ([Key], String)
peelCompleteKeys TreeMap Char Key
tree = ([Key] -> [Key]) -> String -> ([Key], String)
forall {a}. ([Key] -> a) -> String -> (a, String)
go [Key] -> [Key]
forall a. a -> a
id
  where
    go :: ([Key] -> a) -> String -> (a, String)
go [Key] -> a
acc String
cs = case TreeMap Char Key -> String -> Maybe (Key, String)
lookupChars TreeMap Char Key
tree String
cs of
        Just (Key
k, String
rest) -> ([Key] -> a) -> String -> (a, String)
go ([Key] -> a
acc ([Key] -> a) -> ([Key] -> [Key]) -> [Key] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
kKey -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:)) String
rest
        Maybe (Key, String)
Nothing        -> ([Key] -> a
acc [], String
cs)

-- | True if @cs@ matches a /strict/ (non-terminal) prefix of some path
-- in the @TreeMap@ — i.e. it could still be extended into a complete
-- key sequence if more bytes arrive.
isStrictTreePrefix :: TreeMap Char b -> [Char] -> Bool
isStrictTreePrefix :: forall b. TreeMap Char b -> String -> Bool
isStrictTreePrefix TreeMap Char b
_ [] = Bool
False
isStrictTreePrefix (TreeMap Map Char (Maybe b, TreeMap Char b)
m) (Char
c:String
cs) = case Char
-> Map Char (Maybe b, TreeMap Char b)
-> Maybe (Maybe b, TreeMap Char b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
c Map Char (Maybe b, TreeMap Char b)
m of
    Maybe (Maybe b, TreeMap Char b)
Nothing                    -> Bool
False
    Just (Maybe b
_, sub :: TreeMap Char b
sub@(TreeMap Map Char (Maybe b, TreeMap Char b)
sm)) -> case String
cs of
        [] -> Bool -> Bool
not (Map Char (Maybe b, TreeMap Char b) -> Bool
forall k a. Map k a -> Bool
Map.null Map Char (Maybe b, TreeMap Char b)
sm)
        String
_  -> TreeMap Char b -> String -> Bool
forall b. TreeMap Char b -> String -> Bool
isStrictTreePrefix TreeMap Char b
sub String
cs

-----------------------------

withPosixGetEvent :: (MonadIO m, MonadMask m, MonadReader Prefs m)
        => TChan Event -> Handles -> [(String,Key)]
                -> (m Event -> m a) -> m a
withPosixGetEvent :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m, MonadReader Prefs m) =>
TChan Event
-> Handles -> [(String, Key)] -> (m Event -> m a) -> m a
withPosixGetEvent TChan Event
eventChan Handles
h [(String, Key)]
termKeys m Event -> m a
f = Handles -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Handles -> m a -> m a
wrapTerminalOps Handles
h (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
    TreeMap Char Key
baseMap <- Handle -> [(String, Key)] -> m (TreeMap Char Key)
forall (m :: * -> *).
(MonadIO m, MonadReader Prefs m) =>
Handle -> [(String, Key)] -> m (TreeMap Char Key)
getKeySequences (Handles -> Handle
ehIn Handles
h) [(String, Key)]
termKeys
    Int
timeoutMs <- (Prefs -> Int) -> m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> (Prefs -> Word) -> Prefs -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prefs -> Word
keyseqTimeoutMs :: Prefs -> Int)
    TChan Event -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
TChan Event -> m a -> m a
withWindowHandler TChan Event
eventChan
        (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m Event -> m a
f (m Event -> m a) -> m Event -> m a
forall a b. (a -> b) -> a -> b
$ IO Event -> m Event
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Event -> m Event) -> IO Event -> m Event
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> TreeMap Char Key -> TChan Event -> IO Event
getEvent (Handles -> Handle
ehIn Handles
h) Int
timeoutMs TreeMap Char Key
baseMap TChan Event
eventChan

withWindowHandler :: (MonadIO m, MonadMask m) => TChan Event -> m a -> m a
withWindowHandler :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
TChan Event -> m a -> m a
withWindowHandler TChan Event
eventChan = CInt -> Handler -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
CInt -> Handler -> m a -> m a
withHandler CInt
windowChange (Handler -> m a -> m a) -> Handler -> m a -> m a
forall a b. (a -> b) -> a -> b
$
    IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Event -> Event -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan Event
eventChan Event
WindowResize

withSigIntHandler :: (MonadIO m, MonadMask m) => m a -> m a
withSigIntHandler :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withSigIntHandler m a
f = do
    ThreadId
tid <- IO ThreadId -> m ThreadId
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
    CInt -> Handler -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
CInt -> Handler -> m a -> m a
withHandler CInt
keyboardSignal
            (IO () -> Handler
Catch (ThreadId -> Interrupt -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid Interrupt
Interrupt))
            m a
f

withHandler :: (MonadIO m, MonadMask m) => Signal -> Handler -> m a -> m a
withHandler :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
CInt -> Handler -> m a -> m a
withHandler CInt
signal Handler
handler m a
f = do
    Handler
old_handler <- IO Handler -> m Handler
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> m Handler) -> IO Handler -> m Handler
forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
signal Handler
handler Maybe SignalSet
forall a. Maybe a
Nothing
    m a
f m a -> m Handler -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` IO Handler -> m Handler
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
signal Handler
old_handler Maybe SignalSet
forall a. Maybe a
Nothing)

getEvent :: Handle -> Int -> TreeMap Char Key -> TChan Event -> IO Event
getEvent :: Handle -> Int -> TreeMap Char Key -> TChan Event -> IO Event
getEvent Handle
h Int
timeoutMs TreeMap Char Key
baseMap = IO [Event] -> TChan Event -> IO Event
keyEventLoop (IO [Event] -> TChan Event -> IO Event)
-> IO [Event] -> TChan Event -> IO Event
forall a b. (a -> b) -> a -> b
$ do
        [Key]
ks <- Handle -> TreeMap Char Key -> Int -> IO [Key]
getBlockOfKeys Handle
h TreeMap Char Key
baseMap Int
timeoutMs
        [Event] -> IO [Event]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [[Key] -> Event
KeyInput [Key]
ks]

-- | Read at least one key of input, and more if available.
--
-- A multi-byte control sequence (e.g. @\\ESC[A@ for arrow-up) may not
-- arrive in a single read on a slow link such as a low-bandwidth serial
-- port: the @\\ESC@ can land before the @[A@.  When the buffer ends in
-- bytes that are a strict prefix of some known key sequence, we wait up
-- to @timeoutMs@ for the rest before returning.  Otherwise we return as
-- soon as nothing more is buffered.  This mirrors GNU Readline's
-- @keyseq-timeout@.
--
-- The loop tracks bytes and decoded keys side by side: every time we
-- run out of immediately-available input we peel complete keys from the
-- front of the byte buffer and shrink it down to just its trailing
-- (possibly partial) prefix.  That keeps the per-decision work bounded
-- by the size of the in-flight sequence rather than the whole accrued
-- buffer, which matters when bytes trickle in slowly.
--
-- Win32 is unaffected: that backend reads structured @INPUT_RECORD@
-- key events rather than raw bytes, so escape sequences are never
-- fragmented in the first place.
getBlockOfKeys :: Handle -> TreeMap Char Key -> Int -> IO [Key]
getBlockOfKeys :: Handle -> TreeMap Char Key -> Int -> IO [Key]
getBlockOfKeys Handle
h TreeMap Char Key
baseMap Int
timeoutMs = do
    Char
c <- Handle -> IO Char
hGetChar Handle
h
    String -> [Key] -> IO [Key]
loop [Char
c] []
  where
    -- Both lists hold values in reverse (newest first) so that consing a
    -- new element is O(1).  We reverse only at decision points or on
    -- return.
    loop :: String -> [Key] -> IO [Key]
loop String
bytesRev [Key]
keysRev = do
        Bool
ready <- Handle -> Int -> IO Bool
hWaitForInput Handle
h Int
0
        if Bool
ready
            then do
                Char
c <- Handle -> IO Char
hGetChar Handle
h
                String -> [Key] -> IO [Key]
loop (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
bytesRev) [Key]
keysRev
            else
                -- Drain whatever complete keys are sitting at the head of
                -- the byte buffer; what's left is either empty (done) or a
                -- still-in-flight partial sequence.
                let ([Key]
peeled, String
partial) = TreeMap Char Key -> String -> ([Key], String)
peelCompleteKeys TreeMap Char Key
baseMap (ShowS
forall a. [a] -> [a]
reverse String
bytesRev)
                    keysRev' :: [Key]
keysRev'          = [Key] -> [Key]
forall a. [a] -> [a]
reverse [Key]
peeled [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ [Key]
keysRev
                in if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
partial
                    then [Key] -> IO [Key]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Key] -> [Key]
forall a. [a] -> [a]
reverse [Key]
keysRev')
                    else if TreeMap Char Key -> String -> Bool
forall b. TreeMap Char b -> String -> Bool
isStrictTreePrefix TreeMap Char Key
baseMap String
partial
                        then do
                            Bool
arrived <- Handle -> Int -> IO Bool
hWaitForInput Handle
h Int
timeoutMs
                            if Bool
arrived
                                then do
                                    Char
c <- Handle -> IO Char
hGetChar Handle
h
                                    String -> [Key] -> IO [Key]
loop (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
forall a. [a] -> [a]
reverse String
partial) [Key]
keysRev'
                                else [Key] -> IO [Key]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Key] -> [Key]
forall a. [a] -> [a]
reverse [Key]
keysRev' [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ TreeMap Char Key -> String -> [Key]
lexKeys TreeMap Char Key
baseMap String
partial)
                        else [Key] -> IO [Key]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Key] -> [Key]
forall a. [a] -> [a]
reverse [Key]
keysRev' [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ TreeMap Char Key -> String -> [Key]
lexKeys TreeMap Char Key
baseMap String
partial)

stdinTTYHandles, ttyHandles :: MaybeT IO Handles
stdinTTYHandles :: MaybeT IO Handles
stdinTTYHandles = do
    Bool
isInTerm <- IO Bool -> MaybeT IO Bool
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> MaybeT IO Bool) -> IO Bool -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsTerminalDevice Handle
stdin
    Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isInTerm
    ExternalHandle
h <- IOMode -> MaybeT IO ExternalHandle
openTerm IOMode
WriteMode
    -- Don't close stdin, since a different part of the program may use it later.
    Handles -> MaybeT IO Handles
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handles
            { hIn :: ExternalHandle
hIn = Handle -> ExternalHandle
externalHandle Handle
stdin
            , hOut :: ExternalHandle
hOut = ExternalHandle
h
            , closeHandles :: IO ()
closeHandles = Handle -> IO ()
hClose (Handle -> IO ()) -> Handle -> IO ()
forall a b. (a -> b) -> a -> b
$ ExternalHandle -> Handle
eH ExternalHandle
h
            }

ttyHandles :: MaybeT IO Handles
ttyHandles = do
    -- Open the input and output as two separate Handles, since they need
    -- different buffering.
    ExternalHandle
h_in <- IOMode -> MaybeT IO ExternalHandle
openTerm IOMode
ReadMode
    ExternalHandle
h_out <- IOMode -> MaybeT IO ExternalHandle
openTerm IOMode
WriteMode
    Handles -> MaybeT IO Handles
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handles
            { hIn :: ExternalHandle
hIn = ExternalHandle
h_in
            , hOut :: ExternalHandle
hOut = ExternalHandle
h_out
            , closeHandles :: IO ()
closeHandles = Handle -> IO ()
hClose (ExternalHandle -> Handle
eH ExternalHandle
h_in) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose (ExternalHandle -> Handle
eH ExternalHandle
h_out)
            }

openTerm :: IOMode -> MaybeT IO ExternalHandle
openTerm :: IOMode -> MaybeT IO ExternalHandle
openTerm IOMode
mode = (IOException -> MaybeT IO ExternalHandle)
-> MaybeT IO ExternalHandle -> MaybeT IO ExternalHandle
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOException
_::IOException) -> MaybeT IO ExternalHandle
forall a. MaybeT IO a
forall (m :: * -> *) a. MonadPlus m => m a
mzero)
            (MaybeT IO ExternalHandle -> MaybeT IO ExternalHandle)
-> MaybeT IO ExternalHandle -> MaybeT IO ExternalHandle
forall a b. (a -> b) -> a -> b
$ IO ExternalHandle -> MaybeT IO ExternalHandle
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalHandle -> MaybeT IO ExternalHandle)
-> IO ExternalHandle -> MaybeT IO ExternalHandle
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> IO ExternalHandle
openInCodingMode String
"/dev/tty" IOMode
mode

explicitTTYHandles :: Handle -> Handle -> MaybeT IO Handles
explicitTTYHandles :: Handle -> Handle -> MaybeT IO Handles
explicitTTYHandles Handle
h_in Handle
h_out = do
    Bool
isInTerm <- IO Bool -> MaybeT IO Bool
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> MaybeT IO Bool) -> IO Bool -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsTerminalDevice Handle
h_in
    Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isInTerm
    Handles -> MaybeT IO Handles
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handles
            { hIn :: ExternalHandle
hIn = Handle -> ExternalHandle
externalHandle Handle
h_in
            , hOut :: ExternalHandle
hOut = Handle -> ExternalHandle
externalHandle Handle
h_out
            , closeHandles :: IO ()
closeHandles = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            }

posixRunTerm ::
    Handles
    -> [IO (Maybe Layout)]
    -> [(String,Key)]
    -> (forall m b . (MonadIO m, MonadMask m) => m b -> m b)
    -> (forall m . (MonadMask m, CommandMonad m) => EvalTerm (PosixT m))
    -> IO RunTerm
posixRunTerm :: Handles
-> [IO (Maybe Layout)]
-> [(String, Key)]
-> (forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a)
-> (forall (m :: * -> *).
    (MonadMask m, CommandMonad m) =>
    EvalTerm (PosixT m))
-> IO RunTerm
posixRunTerm Handles
hs [IO (Maybe Layout)]
layoutGetters [(String, Key)]
keys forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
wrapGetEvent forall (m :: * -> *).
(MonadMask m, CommandMonad m) =>
EvalTerm (PosixT m)
evalBackend = do
    TChan Event
ch <- IO (TChan Event)
forall a. IO (TChan a)
newTChanIO
    RunTerm
fileRT <- Handles -> IO RunTerm
posixFileRunTerm Handles
hs
    RunTerm -> IO RunTerm
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RunTerm
fileRT
                { termOps = Left TermOps
                            { getLayout = tryGetLayouts layoutGetters
                            , withGetEvent = wrapGetEvent
                                            . withPosixGetEvent ch hs
                                                keys
                            , saveUnusedKeys = saveKeys ch
                            , evalTerm = mapEvalTerm
                                            (runPosixT hs) lift evalBackend
                            , externalPrint = atomically . writeTChan ch . ExternalPrint
                            }
                , closeTerm = do
                    flushEventQueue (putStrOut fileRT) ch
                    closeTerm fileRT
                }

type PosixT m = ReaderT Handles m

runPosixT :: Handles -> PosixT m a -> m a
runPosixT :: forall (m :: * -> *) a. Handles -> PosixT m a -> m a
runPosixT Handles
h = Handles -> ReaderT Handles m a -> m a
forall r (m :: * -> *) a. r -> ReaderT r m a -> m a
runReaderT' Handles
h

fileRunTerm :: Handle -> IO RunTerm
fileRunTerm :: Handle -> IO RunTerm
fileRunTerm Handle
h_in = Handles -> IO RunTerm
posixFileRunTerm Handles
                        { hIn :: ExternalHandle
hIn = Handle -> ExternalHandle
externalHandle Handle
h_in
                        , hOut :: ExternalHandle
hOut = Handle -> ExternalHandle
externalHandle Handle
stdout
                        , closeHandles :: IO ()
closeHandles = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        }

posixFileRunTerm :: Handles -> IO RunTerm
posixFileRunTerm :: Handles -> IO RunTerm
posixFileRunTerm Handles
hs = do
    RunTerm -> IO RunTerm
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RunTerm
                { putStrOut :: String -> IO ()
putStrOut = \String
str -> ExternalHandle -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ExternalHandle -> m a -> m a
withCodingMode (Handles -> ExternalHandle
hOut Handles
hs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                        Handle -> String -> IO ()
hPutStr (Handles -> Handle
ehOut Handles
hs) String
str
                                        Handle -> IO ()
hFlush (Handles -> Handle
ehOut Handles
hs)
                , closeTerm :: IO ()
closeTerm = Handles -> IO ()
closeHandles Handles
hs
                , wrapInterrupt :: forall a (m :: * -> *). (MonadIO m, MonadMask m) => m a -> m a
wrapInterrupt = m a -> m a
forall a (m :: * -> *). (MonadIO m, MonadMask m) => m a -> m a
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withSigIntHandler
                , termOps :: Either TermOps FileOps
termOps = let h_in :: Handle
h_in = Handles -> Handle
ehIn Handles
hs
                            in FileOps -> Either TermOps FileOps
forall a b. b -> Either a b
Right FileOps
                          { withoutInputEcho :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withoutInputEcho = IO Bool -> (Bool -> IO ()) -> Bool -> m a -> m a
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m) =>
IO a -> (a -> IO ()) -> a -> m b -> m b
bracketSet (Handle -> IO Bool
hGetEcho Handle
h_in)
                                                          (Handle -> Bool -> IO ()
hSetEcho Handle
h_in)
                                                          Bool
False
                          , wrapFileInput :: forall a. IO a -> IO a
wrapFileInput = ExternalHandle -> IO a -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ExternalHandle -> m a -> m a
withCodingMode (Handles -> ExternalHandle
hIn Handles
hs)
                          , getLocaleChar :: MaybeT IO Char
getLocaleChar = (Handle -> IO Char) -> Handle -> MaybeT IO Char
forall a. (Handle -> IO a) -> Handle -> MaybeT IO a
guardedEOF Handle -> IO Char
hGetChar Handle
h_in
                          , maybeReadNewline :: IO ()
maybeReadNewline = Handle -> IO ()
hMaybeReadNewline Handle
h_in
                          , getLocaleLine :: MaybeT IO String
getLocaleLine = (Handle -> IO String) -> Handle -> MaybeT IO String
forall a. (Handle -> IO a) -> Handle -> MaybeT IO a
guardedEOF Handle -> IO String
hGetLine Handle
h_in
                          }
                }

-- NOTE: If we set stdout to NoBuffering, there can be a flicker effect when many
-- characters are printed at once.  We'll keep it buffered here, and let the Draw
-- monad manually flush outputs that don't print a newline.
wrapTerminalOps :: (MonadIO m, MonadMask m) => Handles -> m a -> m a
wrapTerminalOps :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Handles -> m a -> m a
wrapTerminalOps Handles
hs =
    IO BufferMode -> (BufferMode -> IO ()) -> BufferMode -> m a -> m a
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m) =>
IO a -> (a -> IO ()) -> a -> m b -> m b
bracketSet (Handle -> IO BufferMode
hGetBuffering Handle
h_in) (Handle -> BufferMode -> IO ()
hSetBuffering Handle
h_in) BufferMode
NoBuffering
    -- TODO: block buffering?  Certain \r and \n's are causing flicker...
    -- - moving to the right
    -- - breaking line after offset widechar?
    (m a -> m a) -> (m a -> m a) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO BufferMode -> (BufferMode -> IO ()) -> BufferMode -> m a -> m a
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m) =>
IO a -> (a -> IO ()) -> a -> m b -> m b
bracketSet (Handle -> IO BufferMode
hGetBuffering Handle
h_out) (Handle -> BufferMode -> IO ()
hSetBuffering Handle
h_out) BufferMode
LineBuffering
    (m a -> m a) -> (m a -> m a) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bool -> (Bool -> IO ()) -> Bool -> m a -> m a
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m) =>
IO a -> (a -> IO ()) -> a -> m b -> m b
bracketSet (Handle -> IO Bool
hGetEcho Handle
h_in) (Handle -> Bool -> IO ()
hSetEcho Handle
h_in) Bool
False
    (m a -> m a) -> (m a -> m a) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExternalHandle -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ExternalHandle -> m a -> m a
withCodingMode (Handles -> ExternalHandle
hIn Handles
hs)
    (m a -> m a) -> (m a -> m a) -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExternalHandle -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ExternalHandle -> m a -> m a
withCodingMode (Handles -> ExternalHandle
hOut Handles
hs)
  where
    h_in :: Handle
h_in = Handles -> Handle
ehIn Handles
hs
    h_out :: Handle
h_out = Handles -> Handle
ehOut Handles
hs