    {-# LINE 1 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
    module System.Console.Haskeline.Backend.Posix (
    {-# LINE 2 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
                            withPosixGetEvent,
                            posixLayouts,
                            tryGetLayouts,
                            PosixT,
                            Handles(),
                            ehIn,
                            ehOut,
                            Encoder,
                            Decoder,
                            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

    {-# LINE 39 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
    import GHC.IO.FD (fdFD)
    import Data.Dynamic (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 50 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}

    {-# LINE 54 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}

    {-# LINE 55 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}

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

    ehIn, ehOut :: Handles -> Handle
    ehIn = eH . hIn
    ehOut = eH . hOut

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

    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 75 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
                    fd <- unsafeHandleToFD h
                    ret <- ioctl fd (1074295912) ws
    {-# LINE 77 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
                    rows :: CUShort <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ws
    {-# LINE 78 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
                    cols :: CUShort <- ((\hsc_ptr -> peekByteOff hsc_ptr 2)) ws
    {-# LINE 79 "libraries/haskeline/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

    {-# LINE 85 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}
    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)

    {-# LINE 95 "libraries/haskeline/System/Console/Haskeline/Backend/Posix.hsc" #-}

    envLayout :: IO (Maybe Layout)
    envLayout = handle (\(_::IOException) -> return Nothing) $ do
        -- note the handle catches both undefined envs and bad reads
        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

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

    getKeySequences :: (MonadIO m, MonadReader Prefs m)
            => Handle -> [(String,Key)] -> m (TreeMap Char Key)
    getKeySequences h tinfos = do
        sttys <- liftIO $ sttyKeys h
        customKeySeqs <- getCustomKeySeqs
        -- note ++ acts as a union; so the below favors sttys over tinfos
        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)
                -- 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:
                ,("\ESC[1;5D", ctrlKey $ simpleKey LeftKey)
                ,("\ESC[1;5C", ctrlKey $ simpleKey RightKey)
                -- Terminal.app:
                ,("\ESC[5D", ctrlKey $ simpleKey LeftKey)
                ,("\ESC[5C", ctrlKey $ simpleKey RightKey)
                -- rxvt: (Note: these will be superceded by e.g. xterm-color,
                -- which uses them as regular arrow keys.)
                ,("\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

    -- for debugging '
    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)
    -- TODO: what's the right thing ' to do here?
        | 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) -- ?? lookup d tm2?
                        -> lookupChars t cs
                    | otherwise -> Just (k, cs)

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

    withPosixGetEvent :: (MonadException m, MonadReader Prefs m)
            => Chan Event -> Handles -> Decoder -> [(String,Key)]
                    -> (m Event -> m a) -> m a
    withPosixGetEvent eventChan h enc termKeys f = wrapTerminalOps h $ do
        baseMap <- getKeySequences (ehIn h) termKeys
        withWindowHandler eventChan
            $ f $ liftIO $ getEvent (ehIn h) enc 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 -> Decoder -> TreeMap Char Key -> Chan Event -> IO Event
    getEvent h dec baseMap = keyEventLoop $ do
            cs <- getBlockOfChars h dec
            return [KeyInput $ lexKeys baseMap cs]

    stdinTTYHandles, ttyHandles :: MaybeT IO Handles
    stdinTTYHandles = do
        isInTerm <- liftIO $ hIsTerminalDevice stdin
        guard isInTerm
        h <- openTerm WriteMode
        -- Don't close stdin, since a different part of the program may use it later.
        return Handles
                { hIn = externalHandle stdin
                , hOut = h
                , closeHandles = hClose $ eH h
                }

    ttyHandles = do
        -- Open the input and output as two separate Handles, since they need
        -- different buffering.
        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
        (enc,dec) <- newEncoders
        return fileRT
                    { closeTerm = closeTerm fileRT
                    , termOps = Left TermOps
                                { getLayout = tryGetLayouts layoutGetters
                                , withGetEvent = wrapGetEvent
                                                . withPosixGetEvent ch hs dec
                                                    keys
                                , saveUnusedKeys = saveKeys ch
                                , evalTerm = mapEvalTerm
                                                (runPosixT enc hs)
                                                    (lift . lift)
                                                evalBackend
                                }
                    }

    type PosixT m = ReaderT Encoder (ReaderT Handles m)

    runPosixT :: Monad m => Encoder -> Handles -> PosixT m a -> m a
    runPosixT enc h = runReaderT' h . runReaderT' enc

    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
        (enc,dec) <- newEncoders
        return RunTerm
                    { putStrOut = \str -> withCodingMode (hOut hs) $ do
                                            putEncodedStr enc (ehOut hs) str
                                            hFlush (ehOut hs)
                    , closeTerm = closeHandles hs
                    , wrapInterrupt = withSigIntHandler
                    , termOps = Right FileOps
                              { inputHandle = ehIn hs
                              , wrapFileInput = withCodingMode (hIn hs)
                              , getLocaleChar = getDecodedChar (ehIn hs) dec
                              , maybeReadNewline = hMaybeReadNewline (ehIn hs)
                              , getLocaleLine = getDecodedLine (ehIn hs) dec
                              }
                    }

    -- 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 :: MonadException m => Handles -> m a -> m a
    wrapTerminalOps hs =
        bracketSet (hGetBuffering h_in) (hSetBuffering h_in) NoBuffering
        -- TODO: block buffering?  Certain \r and \n's are causing flicker...
        -- - moving to the right
        -- - breaking line after offset widechar?
        . 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