{-# LINE 1 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
{-# LANGUAGE CApiFFI #-}
module System.Console.Haskeline.Backend.Posix (
withPosixGetEvent,
posixLayouts,
tryGetLayouts,
PosixT,
Handles(),
ehIn,
ehOut,
mapLines,
stdinTTYHandles,
ttyHandles,
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 52 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handles -> ExternalHandle
hIn
ehOut :: Handles -> Handle
ehOut = ExternalHandle -> Handle
eH forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handles -> ExternalHandle
hOut
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 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 = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes ((Int
8)) forall a b. (a -> b) -> a -> b
$ \Ptr Any
ws -> do
{-# LINE 73 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
CInt
fd <- Handle -> IO CInt
unsafeHandleToFD Handle
h
CInt
ret <- forall a. CInt -> CULong -> Ptr a -> IO CInt
ioctl CInt
fd (CULong
21523) Ptr Any
ws
{-# LINE 75 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
CUShort
rows :: CUShort <- ((\Ptr Any
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
hsc_ptr Int
0)) Ptr Any
ws
{-# LINE 76 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
CUShort
cols :: CUShort <- ((\Ptr Any
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
hsc_ptr Int
2)) Ptr Any
ws
{-# LINE 77 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
if CInt
ret forall a. Ord a => a -> a -> Bool
>= CInt
0
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Layout {height :: Int
height=forall a. Enum a => a -> Int
fromEnum CUShort
rows,width :: Int
width=forall a. Enum a => a -> Int
fromEnum CUShort
cols}
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
unsafeHandleToFD :: Handle -> IO FD
unsafeHandleToFD :: Handle -> IO CInt
unsafeHandleToFD Handle
h =
forall a. String -> Handle -> (Handle__ -> IO a) -> IO a
withHandle_ String
"unsafeHandleToFd" Handle
h forall a b. (a -> b) -> a -> b
$ \Handle__{haDevice :: ()
haDevice=dev
dev} -> do
case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast dev
dev of
Maybe FD
Nothing -> forall a. IOException -> IO a
ioError (IOException -> String -> IOException
ioeSetErrorString (IOErrorType
-> String -> Maybe Handle -> Maybe String -> IOException
mkIOError IOErrorType
IllegalOperation
String
"unsafeHandleToFd" (forall a. a -> Maybe a
Just Handle
h) forall a. Maybe a
Nothing)
String
"handle is not a file descriptor")
Just FD
fd -> forall (m :: * -> *) a. Monad m => a -> m a
return (FD -> CInt
fdFD FD
fd)
envLayout :: IO (Maybe Layout)
envLayout :: IO (Maybe Layout)
envLayout = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOException
_::IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
String
r <- String -> IO String
getEnv String
"ROWS"
String
c <- String -> IO String
getEnv String
"COLUMNS"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Layout {height :: Int
height=forall a. Read a => String -> a
read String
r,width :: Int
width=forall a. Read a => String -> a
read String
c}
tryGetLayouts :: [IO (Maybe Layout)] -> IO Layout
tryGetLayouts :: [IO (Maybe Layout)] -> IO Layout
tryGetLayouts [] = 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 forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
&& Layout -> Int
width Layout
l forall a. Ord a => a -> a -> Bool
> Int
2 -> forall (m :: * -> *) a. Monad m => a -> m a
return Layout
l
Maybe Layout
_ -> [IO (Maybe Layout)] -> IO Layout
tryGetLayouts [IO (Maybe Layout)]
fs
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO [(String, Key)]
sttyKeys Handle
h
[(String, Key)]
customKeySeqs <- m [(String, Key)]
getCustomKeySeqs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. Ord a => [([a], b)] -> TreeMap a b
listToTree
forall a b. (a -> b) -> a -> b
$ [(String, Key)]
ansiKeys forall a. [a] -> [a] -> [a]
++ [(String, Key)]
tinfos forall a. [a] -> [a] -> [a]
++ [(String, Key)]
sttys forall a. [a] -> [a] -> [a]
++ [(String, Key)]
customKeySeqs
where
getCustomKeySeqs :: m [(String, Key)]
getCustomKeySeqs = do
[(Maybe String, String, Key)]
kseqs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Prefs -> [(Maybe String, String, Key)]
customKeySequences
String
termName <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOException
_::IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return String
"") (String -> IO String
getEnv String
"TERM")
let isThisTerm :: Maybe String -> Bool
isThisTerm = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
==String
termName)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe String
_,String
cs,Key
k) ->(String
cs,Key
k))
forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(Maybe String
kseqs',String
_,Key
_) -> Maybe String -> Bool
isThisTerm Maybe String
kseqs')
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)
,(String
"\ESC[1;5D", Key -> Key
ctrlKey forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
LeftKey)
,(String
"\ESC[1;5C", Key -> Key
ctrlKey forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
RightKey)
,(String
"\ESC[5D", Key -> Key
ctrlKey forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
LeftKey)
,(String
"\ESC[5C", Key -> Key
ctrlKey forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
RightKey)
,(String
"\ESC[OD", Key -> Key
ctrlKey forall a b. (a -> b) -> a -> b
$ BaseKey -> Key
simpleKey BaseKey
LeftKey)
,(String
"\ESC[OC", Key -> Key
ctrlKey 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; forall (m :: * -> *) a. Monad m => a -> m a
return ([Char
str],b
c)}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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
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
showList :: [TreeMap a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [TreeMap a b] -> ShowS
show :: TreeMap a b -> String
$cshow :: forall a b. (Show a, Show b) => TreeMap a b -> String
showsPrec :: Int -> TreeMap a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> TreeMap a b -> ShowS
Show
emptyTreeMap :: TreeMap a b
emptyTreeMap :: forall a b. TreeMap a b
emptyTreeMap = forall a b. Map a (Maybe b, TreeMap a b) -> TreeMap a b
TreeMap 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
_ = 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) = forall a b. Map a (Maybe b, TreeMap a b) -> TreeMap a b
TreeMap (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 = 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
cs
then (forall a. a -> Maybe a
Just b
k, forall a b. TreeMap a b
emptyTreeMap)
else (forall a. Maybe a
Nothing, TreeMap a b -> TreeMap a b
alterSubtree forall a b. TreeMap a b
emptyTreeMap)
f (Just (Maybe b
y,TreeMap a b
t)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
cs
then (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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Ord a => ([a], b) -> TreeMap a b -> TreeMap a b
insertIntoTree) forall a b. TreeMap a b
emptyTreeMap
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 = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(Maybe b
k,TreeMap a b
t) -> forall a. Show a => a -> String
show Maybe b
k forall a. a -> [a] -> [a]
: 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 forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(a
k,[String]
ls) -> forall a. Show a => a -> String
show a
k forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Char
' 'forall a. a -> [a] -> [a]
:) [String]
ls) forall a b. (a -> b) -> a -> b
$ 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 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)
| Key
k:[Key]
ks <- TreeMap Char Key -> String -> [Key]
lexKeys TreeMap Char Key
baseMap String
cs
= Key -> Key
metaKey Key
k forall a. a -> [a] -> [a]
: [Key]
ks
lexKeys TreeMap Char Key
baseMap (Char
c:String
cs) = Char -> Key
simpleChar Char
c forall a. a -> [a] -> [a]
: TreeMap Char Key -> String -> [Key]
lexKeys TreeMap Char Key
baseMap String
cs
lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key,[Char])
lookupChars :: TreeMap Char Key -> String -> Maybe (Key, String)
lookupChars TreeMap Char Key
_ [] = forall a. Maybe a
Nothing
lookupChars (TreeMap Map Char (Maybe Key, TreeMap Char Key)
tm) (Char
c:String
cs) = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
c Map Char (Maybe Key, TreeMap Char Key)
tm of
Maybe (Maybe Key, TreeMap Char Key)
Nothing -> forall a. Maybe a
Nothing
Just (Maybe Key
Nothing,TreeMap Char Key
t) -> TreeMap Char Key -> String -> Maybe (Key, String)
lookupChars TreeMap Char Key
t String
cs
Just (Just Key
k, t :: TreeMap Char Key
t@(TreeMap Map Char (Maybe Key, TreeMap Char Key)
tm2))
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cs) Bool -> Bool -> Bool
&& Bool -> Bool
not (forall k a. Map k a -> Bool
Map.null Map Char (Maybe Key, TreeMap Char Key)
tm2)
-> TreeMap Char Key -> String -> Maybe (Key, String)
lookupChars TreeMap Char Key
t String
cs
| Bool
otherwise -> forall a. a -> Maybe a
Just (Key
k, 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 = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Handles -> m a -> m a
wrapTerminalOps Handles
h forall a b. (a -> b) -> a -> b
$ do
TreeMap Char Key
baseMap <- forall (m :: * -> *).
(MonadIO m, MonadReader Prefs m) =>
Handle -> [(String, Key)] -> m (TreeMap Char Key)
getKeySequences (Handles -> Handle
ehIn Handles
h) [(String, Key)]
termKeys
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
TChan Event -> m a -> m a
withWindowHandler TChan Event
eventChan
forall a b. (a -> b) -> a -> b
$ m Event -> m a
f forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> TreeMap Char Key -> TChan Event -> IO Event
getEvent (Handles -> Handle
ehIn Handles
h) 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 = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
CInt -> Handler -> m a -> m a
withHandler CInt
windowChange forall a b. (a -> b) -> a -> b
$
IO () -> Handler
Catch forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
CInt -> Handler -> m a -> m a
withHandler CInt
keyboardSignal
(IO () -> Handler
Catch (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
signal Handler
handler forall a. Maybe a
Nothing
m a
f forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
signal Handler
old_handler forall a. Maybe a
Nothing)
getEvent :: Handle -> TreeMap Char Key -> TChan Event -> IO Event
getEvent :: Handle -> TreeMap Char Key -> TChan Event -> IO Event
getEvent Handle
h TreeMap Char Key
baseMap = IO [Event] -> TChan Event -> IO Event
keyEventLoop forall a b. (a -> b) -> a -> b
$ do
String
cs <- Handle -> IO String
getBlockOfChars Handle
h
forall (m :: * -> *) a. Monad m => a -> m a
return [[Key] -> Event
KeyInput forall a b. (a -> b) -> a -> b
$ TreeMap Char Key -> String -> [Key]
lexKeys TreeMap Char Key
baseMap String
cs]
getBlockOfChars :: Handle -> IO String
getBlockOfChars :: Handle -> IO String
getBlockOfChars Handle
h = do
Char
c <- Handle -> IO Char
hGetChar Handle
h
String -> IO String
loop [Char
c]
where
loop :: String -> IO String
loop String
cs = do
Bool
isReady <- Handle -> IO Bool
hReady Handle
h
if Bool -> Bool
not Bool
isReady
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse String
cs
else do
Char
c <- Handle -> IO Char
hGetChar Handle
h
String -> IO String
loop (Char
cforall a. a -> [a] -> [a]
:String
cs)
stdinTTYHandles, ttyHandles :: MaybeT IO Handles
stdinTTYHandles :: MaybeT IO Handles
stdinTTYHandles = do
Bool
isInTerm <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsTerminalDevice Handle
stdin
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isInTerm
ExternalHandle
h <- IOMode -> MaybeT IO ExternalHandle
openTerm IOMode
WriteMode
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 forall a b. (a -> b) -> a -> b
$ ExternalHandle -> Handle
eH ExternalHandle
h
}
ttyHandles :: MaybeT IO Handles
ttyHandles = do
ExternalHandle
h_in <- IOMode -> MaybeT IO ExternalHandle
openTerm IOMode
ReadMode
ExternalHandle
h_out <- IOMode -> MaybeT IO ExternalHandle
openTerm IOMode
WriteMode
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) 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 = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(IOException
_::IOException) -> forall (m :: * -> *) a. MonadPlus m => m a
mzero)
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IOMode -> IO ExternalHandle
openInCodingMode String
"/dev/tty" IOMode
mode
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 <- forall a. IO (TChan a)
newTChanIO
RunTerm
fileRT <- Handles -> IO RunTerm
posixFileRunTerm Handles
hs
forall (m :: * -> *) a. Monad m => a -> m a
return RunTerm
fileRT
{ termOps :: Either TermOps FileOps
termOps = forall a b. a -> Either a b
Left TermOps
{ getLayout :: IO Layout
getLayout = [IO (Maybe Layout)] -> IO Layout
tryGetLayouts [IO (Maybe Layout)]
layoutGetters
, withGetEvent :: forall (m :: * -> *) a. CommandMonad m => (m Event -> m a) -> m a
withGetEvent = forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
wrapGetEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m, MonadReader Prefs m) =>
TChan Event
-> Handles -> [(String, Key)] -> (m Event -> m a) -> m a
withPosixGetEvent TChan Event
ch Handles
hs
[(String, Key)]
keys
, saveUnusedKeys :: [Key] -> IO ()
saveUnusedKeys = TChan Event -> [Key] -> IO ()
saveKeys TChan Event
ch
, evalTerm :: forall (m :: * -> *). CommandMonad m => EvalTerm m
evalTerm = forall (n :: * -> *) (m :: * -> *).
(forall a. n a -> m a)
-> (forall a. m a -> n a) -> EvalTerm n -> EvalTerm m
mapEvalTerm
(forall (m :: * -> *) a. Handles -> PosixT m a -> m a
runPosixT Handles
hs) forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *).
(MonadMask m, CommandMonad m) =>
EvalTerm (PosixT m)
evalBackend
, externalPrint :: String -> IO ()
externalPrint = forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TChan a -> a -> STM ()
writeTChan TChan Event
ch forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Event
ExternalPrint
}
, closeTerm :: IO ()
closeTerm = do
(String -> IO ()) -> TChan Event -> IO ()
flushEventQueue (RunTerm -> String -> IO ()
putStrOut RunTerm
fileRT) TChan Event
ch
RunTerm -> IO ()
closeTerm RunTerm
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 = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
posixFileRunTerm :: Handles -> IO RunTerm
posixFileRunTerm :: Handles -> IO RunTerm
posixFileRunTerm Handles
hs = do
forall (m :: * -> *) a. Monad m => a -> m a
return RunTerm
{ putStrOut :: String -> IO ()
putStrOut = \String
str -> forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ExternalHandle -> m a -> m a
withCodingMode (Handles -> ExternalHandle
hOut Handles
hs) 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 = 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 forall a b. b -> Either a b
Right FileOps
{ withoutInputEcho :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withoutInputEcho = 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 = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ExternalHandle -> m a -> m a
withCodingMode (Handles -> ExternalHandle
hIn Handles
hs)
, getLocaleChar :: MaybeT IO Char
getLocaleChar = 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 = forall a. (Handle -> IO a) -> Handle -> MaybeT IO a
guardedEOF Handle -> IO String
hGetLine Handle
h_in
}
}
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 =
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
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ExternalHandle -> m a -> m a
withCodingMode (Handles -> ExternalHandle
hIn Handles
hs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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