    -- |
    -- Maintainer  : judah.jacobson@gmail.com
    -- Stability   : experimental
    -- Portability : portable (FFI)
    --
    -- This module provides a low-level interface to the C functions of the
    -- terminfo library.
    --
    -- NOTE: Since this library is built on top of the curses interface, it is not thread-safe.

    module System.Console.Terminfo.Base(
                                -- *  Initialization
                                Terminal(),
                                setupTerm,
                                setupTermFromEnv,
                                SetupTermError,
                                -- * Capabilities
                                Capability,
                                getCapability,
                                tiGetFlag,
                                tiGuardFlag,
                                tiGetNum,
                                tiGetStr,
                                -- * Output
                                TermOutput(),
                                runTermOutput,
                                hRunTermOutput,
                                termText,
                                tiGetOutput,
                                LinesAffected,
                                tiGetOutput1,
                                OutputCap,
                                -- ** Monoid functions
                                Monoid(..),
                                (<#>)
                                ) where

    import Control.Monad
    import Data.Monoid
    import Foreign.C
    import Foreign.ForeignPtr
    import Foreign.Ptr
    import Foreign.Marshal
    import Foreign.Storable (peek,poke)
    import System.Environment (getEnv)
    import System.IO.Unsafe (unsafePerformIO)
    import System.IO
    import Control.Exception.Extensible
    import Data.Typeable

    data TERMINAL
    newtype Terminal = Terminal (ForeignPtr TERMINAL)

    foreign import ccall "&" cur_term :: Ptr (Ptr TERMINAL)
    foreign import ccall set_curterm :: Ptr TERMINAL -> IO (Ptr TERMINAL)
    foreign import ccall "&" del_curterm :: FunPtr (Ptr TERMINAL -> IO ())

    foreign import ccall setupterm :: CString -> CInt -> Ptr CInt -> IO ()

    -- | Initialize the terminfo library to the given terminal entry.
    --
    -- Throws a 'SetupTermError' if the terminfo database could not be read.
    setupTerm :: String -> IO Terminal
    setupTerm term = bracket (peek cur_term) (poke cur_term) $ \_ ->
        withCString term $ \c_term ->
        with 0 $ \ret_ptr -> do
            -- NOTE: I believe that for the way we use terminfo
            -- (i.e. custom output function)
            -- this parameter does not affect anything.
            let stdOutput = 1
            {-- Force ncurses to return a new struct rather than
            a copy of the current one (which it would do if the
            terminal names are the same).  This prevents problems
            when calling del_term on a struct shared by more than one
            Terminal. --}
            poke cur_term nullPtr
            -- Call setupterm and check the return value.
            setupterm c_term stdOutput ret_ptr
            ret <- peek ret_ptr
            if (ret /=1)
                then throwIO $ SetupTermError
                    $ "Couldn't look up terminfo entry " ++ show term
                else do
                    cterm <- peek cur_term
                    fmap Terminal $ newForeignPtr del_curterm cterm

    data SetupTermError = SetupTermError String
                            deriving Typeable

    instance Show SetupTermError where
        show (SetupTermError str) = "setupTerm: " ++ str

    instance Exception SetupTermError where

    -- | Initialize the terminfo library, using the @TERM@ environmental variable.
    -- If @TERM@ is not set, we use the generic, minimal entry @dumb@.
    --
    -- Throws a 'SetupTermError' if the terminfo database could not be read.
    setupTermFromEnv :: IO Terminal
    setupTermFromEnv = do
        env_term <- handle handleBadEnv $ getEnv "TERM"
        let term = if null env_term then "dumb" else env_term
        setupTerm term
      where
        handleBadEnv :: IOException -> IO String
        handleBadEnv _ = return ""

    withCurTerm :: Terminal -> IO a -> IO a
    withCurTerm (Terminal term) f = withForeignPtr term $ \cterm -> do
            old_term <- peek cur_term
            if old_term /= cterm
                then do
                        set_curterm cterm
                        x <- f
                        set_curterm old_term
                        return x
                else f

    -- | A feature or operation which a 'Terminal' may define.
    newtype Capability a = Capability (IO (Maybe a))

    getCapability :: Terminal -> Capability a -> Maybe a
    getCapability term (Capability f) = unsafePerformIO $ withCurTerm term f

    -- Note that the instances for Capability of Functor, Monad and MonadPlus
    -- use the corresponding instances for Maybe.
    instance Functor Capability where
        fmap f (Capability g) = Capability (fmap (fmap f) g)

    instance Monad Capability where
        return = Capability . return . Just
        Capability f >>= g = Capability $ do
            mx <- f
            case mx of
                Nothing -> return Nothing
                Just x -> let Capability g' = g x in g'

    instance MonadPlus Capability where
        mzero = Capability (return Nothing)
        Capability f `mplus` Capability g = Capability $ do
            mx <- f
            case mx of
                Nothing -> g
                _ -> return mx

    foreign import ccall tigetnum :: CString -> IO CInt

    -- | Look up a numeric capability in the terminfo database.
    tiGetNum :: String -> Capability Int
    tiGetNum cap = Capability $ do
                    n <- fmap fromEnum (withCString cap tigetnum)
                    if n >= 0
                        then return (Just n)
                        else return Nothing

    foreign import ccall tigetflag :: CString -> IO CInt
    -- | Look up a boolean capability in the terminfo database.
    --
    -- Unlike 'tiGuardFlag', this capability never fails; it returns 'False' if the
    -- capability is absent or set to false, and returns 'True' otherwise.
    --
    tiGetFlag :: String -> Capability Bool
    tiGetFlag cap = Capability $ fmap (Just . (>0)) $
                            withCString cap tigetflag

    -- | Look up a boolean capability in the terminfo database, and fail if
    -- it\'s not defined.
    tiGuardFlag :: String -> Capability ()
    tiGuardFlag cap = tiGetFlag cap >>= guard

    foreign import ccall tigetstr :: CString -> IO CString

    -- | Look up a string capability in the terminfo database.
    --
    -- Note: Do not use this function for terminal output; use 'tiGetOutput'
    -- instead.
    tiGetStr :: String -> Capability String
    tiGetStr cap = Capability $ do
                    result <- withCString cap tigetstr
                    if result == nullPtr || result == neg1Ptr
                        then return Nothing
                        else fmap Just (peekCString result)
        where
            -- hack; tigetstr sometimes returns (-1)
            neg1Ptr = nullPtr `plusPtr` (-1)

    foreign import ccall tparm ::
        CString -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong
        -> CLong -> CLong -> CLong -- p1,...,p9
        -> IO CString

    -- Note: I may want to cut out the middleman and pipe tGoto/tGetStr together
    -- with tput without a String marshall in the middle.
    -- directly without

    tParm :: String -> [Int] -> IO String
    tParm cap ps = tparm' (map toEnum ps ++ repeat 0)
        where tparm' (p1:p2:p3:p4:p5:p6:p7:p8:p9:_)
                = withCString cap $ \c_cap -> do
                    result <- tparm c_cap p1 p2 p3 p4 p5 p6 p7 p8 p9
                    peekCString result
              tparm' _ = fail "tParm: List too short"

    -- | Look up an output capability in the terminfo database.
    tiGetOutput :: String -> Capability ([Int] -> LinesAffected -> TermOutput)
    tiGetOutput cap = flip fmap (tiGetStr cap) $
        \str ps la -> TermOutput $ \_ putc -> do
            outStr <- tParm str ps
            tPuts outStr la putc

    type CharOutput = CInt -> IO CInt

    foreign import ccall "wrapper" mkCallback :: CharOutput -> IO (FunPtr CharOutput)

    foreign import ccall tputs :: CString -> CInt -> FunPtr CharOutput -> IO ()

    -- | A parameter to specify the number of lines affected.  Some capabilities
    -- (e.g., @clear@ and @dch1@) use
    -- this parameter on some terminals to compute variable-length padding.
    type LinesAffected = Int

    -- | Output a string capability.  Applys padding information to the string if
    -- necessary.
    tPuts :: String -> LinesAffected -> FunPtr CharOutput -> IO ()
    tPuts s n putc = withCString s $ \c_str -> tputs c_str (toEnum n) putc

    -- | An action which sends output to the terminal.  That output may mix plain text with control
    -- characters and escape sequences, along with delays (called \"padding\") required by some older
    -- terminals.
    newtype TermOutput = TermOutput (Handle -> FunPtr CharOutput -> IO ())

    -- | Write the terminal output to the standard output device.
    runTermOutput :: Terminal -> TermOutput -> IO ()
    runTermOutput = hRunTermOutput stdout

    -- | Write the terminal output to the terminal or file managed by the given
    -- 'Handle'.
    hRunTermOutput :: Handle -> Terminal -> TermOutput -> IO ()
    hRunTermOutput h term (TermOutput to) = do
        putc_ptr <- mkCallback putc
        withCurTerm term (to h putc_ptr)
        freeHaskellFunPtr putc_ptr
      where
        putc c = let c' = toEnum $ fromEnum c
                 in hPutChar h c' >> hFlush h >> return c

    -- | Output plain text containing no control characters or escape sequences.
    termText :: String -> TermOutput
    termText str = TermOutput $ \h _ -> hPutStr h str >> hFlush h

    instance Monoid TermOutput where
        mempty = TermOutput $ \_ _ -> return ()
        TermOutput f `mappend` TermOutput g = TermOutput $ \h putc -> f h putc >> g h putc

    -- | A type class to encapsulate capabilities which take in zero or more
    -- parameters.
    class OutputCap f where
        outputCap :: ([Int] -> TermOutput) -> [Int] -> f

    instance OutputCap TermOutput where
        outputCap f xs = f (reverse xs)

    instance (Enum a, OutputCap f) => OutputCap (a -> f) where
        outputCap f xs = \x -> outputCap f (fromEnum x:xs)

    -- | Look up an output capability which takes a fixed number of parameters
    -- (for example, @Int -> Int -> TermOutput@).
    --
    -- For capabilities which may contain variable-length
    -- padding, use 'tiGetOutput' instead.
    tiGetOutput1 :: OutputCap f => String -> Capability f
    tiGetOutput1 str = fmap (\f -> outputCap (flip f 1) []) $ tiGetOutput str

    infixl 2 <#>

    -- | An operator version of 'mappend'.
    (<#>) :: Monoid m => m -> m -> m
    (<#>) = mappend