{-# LINE 1 "System/Console/Haskeline/Backend/Posix.hsc" #-}
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.Monad
import Control.Concurrent hiding (throwTo)
import Data.Maybe (catMaybes)
import System.Posix.Signals.Exts
import System.Posix.Types(Fd(..))
import Data.List
import System.IO
import System.Environment
import System.Console.Haskeline.Monads hiding (Handler)
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 47 "System/Console/Haskeline/Backend/Posix.hsc" #-}
data Handles = Handles {hIn, hOut :: ExternalHandle
, closeHandles :: IO ()}
ehIn, ehOut :: Handles -> Handle
ehIn = eH . hIn
ehOut = eH . hOut
foreign import ccall ioctl :: FD -> CULong -> Ptr a -> IO CInt
posixLayouts :: Handles -> [IO (Maybe Layout)]
posixLayouts h = [ioctlLayout $ ehOut h, envLayout]
ioctlLayout :: Handle -> IO (Maybe Layout)
ioctlLayout h = allocaBytes ((8)) $ \ws -> do
{-# LINE 68 "System/Console/Haskeline/Backend/Posix.hsc" #-}
fd <- unsafeHandleToFD h
ret <- ioctl fd (21523) ws
{-# LINE 70 "System/Console/Haskeline/Backend/Posix.hsc" #-}
rows :: CUShort <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ws
{-# LINE 71 "System/Console/Haskeline/Backend/Posix.hsc" #-}
cols :: CUShort <- ((\hsc_ptr -> peekByteOff hsc_ptr 2)) ws
{-# LINE 72 "System/Console/Haskeline/Backend/Posix.hsc" #-}
if ret >= 0
then return $ Just Layout {height=fromEnum rows,width=fromEnum cols}
else return Nothing
unsafeHandleToFD :: Handle -> IO FD
unsafeHandleToFD h =
withHandle_ "unsafeHandleToFd" h $ \Handle__{haDevice=dev} -> do
case cast dev of
Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation
"unsafeHandleToFd" (Just h) Nothing)
"handle is not a file descriptor")
Just fd -> return (fdFD fd)
envLayout :: IO (Maybe Layout)
envLayout = handle (\(_::IOException) -> return Nothing) $ do
r <- getEnv "ROWS"
c <- getEnv "COLUMNS"
return $ Just $ Layout {height=read r,width=read c}
tryGetLayouts :: [IO (Maybe Layout)] -> IO Layout
tryGetLayouts [] = return Layout {height=24,width=80}
tryGetLayouts (f:fs) = do
ml <- f
case ml of
Just l | height l > 2 && width l > 2 -> return l
_ -> tryGetLayouts fs
getKeySequences :: (MonadIO m, MonadReader Prefs m)
=> Handle -> [(String,Key)] -> m (TreeMap Char Key)
getKeySequences h tinfos = do
sttys <- liftIO $ sttyKeys h
customKeySeqs <- getCustomKeySeqs
return $ listToTree
$ ansiKeys ++ tinfos ++ sttys ++ customKeySeqs
where
getCustomKeySeqs = do
kseqs <- asks customKeySequences
termName <- liftIO $ handle (\(_::IOException) -> return "") (getEnv "TERM")
let isThisTerm = maybe True (==termName)
return $ map (\(_,cs,k) ->(cs,k))
$ filter (\(kseqs',_,_) -> isThisTerm kseqs')
$ kseqs
ansiKeys :: [(String, Key)]
ansiKeys = [("\ESC[D", simpleKey LeftKey)
,("\ESC[C", simpleKey RightKey)
,("\ESC[A", simpleKey UpKey)
,("\ESC[B", simpleKey DownKey)
,("\b", simpleKey Backspace)
,("\ESC[1;5D", ctrlKey $ simpleKey LeftKey)
,("\ESC[1;5C", ctrlKey $ simpleKey RightKey)
,("\ESC[5D", ctrlKey $ simpleKey LeftKey)
,("\ESC[5C", ctrlKey $ simpleKey RightKey)
,("\ESC[OD", ctrlKey $ simpleKey LeftKey)
,("\ESC[OC", ctrlKey $ simpleKey RightKey)
]
sttyKeys :: Handle -> IO [(String, Key)]
sttyKeys h = do
fd <- unsafeHandleToFD h
attrs <- getTerminalAttributes (Fd fd)
let getStty (k,c) = do {str <- controlChar attrs k; return ([str],c)}
return $ catMaybes $ map getStty [(Erase,simpleKey Backspace),(Kill,simpleKey KillLine)]
newtype TreeMap a b = TreeMap (Map.Map a (Maybe b, TreeMap a b))
deriving Show
emptyTreeMap :: TreeMap a b
emptyTreeMap = TreeMap Map.empty
insertIntoTree :: Ord a => ([a], b) -> TreeMap a b -> TreeMap a b
insertIntoTree ([],_) _ = error "Can't insert empty list into a treemap!"
insertIntoTree ((c:cs),k) (TreeMap m) = TreeMap (Map.alter f c m)
where
alterSubtree = insertIntoTree (cs,k)
f Nothing = Just $ if null cs
then (Just k, emptyTreeMap)
else (Nothing, alterSubtree emptyTreeMap)
f (Just (y,t)) = Just $ if null cs
then (Just k, t)
else (y, alterSubtree t)
listToTree :: Ord a => [([a],b)] -> TreeMap a b
listToTree = foldl' (flip insertIntoTree) emptyTreeMap
mapLines :: (Show a, Show b) => TreeMap a b -> [String]
mapLines (TreeMap m) = let
m2 = Map.map (\(k,t) -> show k : mapLines t) m
in concatMap (\(k,ls) -> show k : map (' ':) ls) $ Map.toList m2
lexKeys :: TreeMap Char Key -> [Char] -> [Key]
lexKeys _ [] = []
lexKeys baseMap cs
| Just (k,ds) <- lookupChars baseMap cs
= k : lexKeys baseMap ds
lexKeys baseMap ('\ESC':cs)
| k:ks <- lexKeys baseMap cs
= metaKey k : ks
lexKeys baseMap (c:cs) = simpleChar c : lexKeys baseMap cs
lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key,[Char])
lookupChars _ [] = Nothing
lookupChars (TreeMap tm) (c:cs) = case Map.lookup c tm of
Nothing -> Nothing
Just (Nothing,t) -> lookupChars t cs
Just (Just k, t@(TreeMap tm2))
| not (null cs) && not (Map.null tm2)
-> lookupChars t cs
| otherwise -> Just (k, cs)
withPosixGetEvent :: (MonadException m, MonadReader Prefs m)
=> Chan Event -> Handles -> [(String,Key)]
-> (m Event -> m a) -> m a
withPosixGetEvent eventChan h termKeys f = wrapTerminalOps h $ do
baseMap <- getKeySequences (ehIn h) termKeys
withWindowHandler eventChan
$ f $ liftIO $ getEvent (ehIn h) baseMap eventChan
withWindowHandler :: MonadException m => Chan Event -> m a -> m a
withWindowHandler eventChan = withHandler windowChange $
Catch $ writeChan eventChan WindowResize
withSigIntHandler :: MonadException m => m a -> m a
withSigIntHandler f = do
tid <- liftIO myThreadId
withHandler keyboardSignal
(Catch (throwTo tid Interrupt))
f
withHandler :: MonadException m => Signal -> Handler -> m a -> m a
withHandler signal handler f = do
old_handler <- liftIO $ installHandler signal handler Nothing
f `finally` liftIO (installHandler signal old_handler Nothing)
getEvent :: Handle -> TreeMap Char Key -> Chan Event -> IO Event
getEvent h baseMap = keyEventLoop $ do
cs <- getBlockOfChars h
return [KeyInput $ lexKeys baseMap cs]
getBlockOfChars :: Handle -> IO String
getBlockOfChars h = do
c <- hGetChar h
loop [c]
where
loop cs = do
isReady <- hReady h
if not isReady
then return $ reverse cs
else do
c <- hGetChar h
loop (c:cs)
stdinTTYHandles, ttyHandles :: MaybeT IO Handles
stdinTTYHandles = do
isInTerm <- liftIO $ hIsTerminalDevice stdin
guard isInTerm
h <- openTerm WriteMode
return Handles
{ hIn = externalHandle stdin
, hOut = h
, closeHandles = hClose $ eH h
}
ttyHandles = do
h_in <- openTerm ReadMode
h_out <- openTerm WriteMode
return Handles
{ hIn = h_in
, hOut = h_out
, closeHandles = hClose (eH h_in) >> hClose (eH h_out)
}
openTerm :: IOMode -> MaybeT IO ExternalHandle
openTerm mode = handle (\(_::IOException) -> mzero)
$ liftIO $ openInCodingMode "/dev/tty" mode
posixRunTerm ::
Handles
-> [IO (Maybe Layout)]
-> [(String,Key)]
-> (forall m b . MonadException m => m b -> m b)
-> (forall m . (MonadException m, CommandMonad m) => EvalTerm (PosixT m))
-> IO RunTerm
posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do
ch <- newChan
fileRT <- posixFileRunTerm hs
return fileRT
{ termOps = Left TermOps
{ getLayout = tryGetLayouts layoutGetters
, withGetEvent = wrapGetEvent
. withPosixGetEvent ch hs
keys
, saveUnusedKeys = saveKeys ch
, evalTerm = mapEvalTerm
(runPosixT hs) lift evalBackend
, externalPrint = writeChan ch . ExternalPrint
}
, closeTerm = do
flushEventQueue (putStrOut fileRT) ch
closeTerm fileRT
}
type PosixT m = ReaderT Handles m
runPosixT :: Monad m => Handles -> PosixT m a -> m a
runPosixT h = runReaderT' h
fileRunTerm :: Handle -> IO RunTerm
fileRunTerm h_in = posixFileRunTerm Handles
{ hIn = externalHandle h_in
, hOut = externalHandle stdout
, closeHandles = return ()
}
posixFileRunTerm :: Handles -> IO RunTerm
posixFileRunTerm hs = do
return RunTerm
{ putStrOut = \str -> withCodingMode (hOut hs) $ do
hPutStr (ehOut hs) str
hFlush (ehOut hs)
, closeTerm = closeHandles hs
, wrapInterrupt = withSigIntHandler
, termOps = let h_in = ehIn hs
in Right FileOps
{ withoutInputEcho = bracketSet (hGetEcho h_in)
(hSetEcho h_in)
False
, wrapFileInput = withCodingMode (hIn hs)
, getLocaleChar = guardedEOF hGetChar h_in
, maybeReadNewline = hMaybeReadNewline h_in
, getLocaleLine = guardedEOF hGetLine h_in
}
}
wrapTerminalOps :: MonadException m => Handles -> m a -> m a
wrapTerminalOps hs =
bracketSet (hGetBuffering h_in) (hSetBuffering h_in) NoBuffering
. bracketSet (hGetBuffering h_out) (hSetBuffering h_out) LineBuffering
. bracketSet (hGetEcho h_in) (hSetEcho h_in) False
. liftIOOp_ (withCodingMode $ hIn hs)
. liftIOOp_ (withCodingMode $ hOut hs)
where
h_in = ehIn hs
h_out = ehOut hs