{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Linenoise.FFI
( InputResult (..)
, addHistory
, clearScreen
, getInputLine
, historyLoad
, historySave
, printKeycodes
, setCompletion
, setMultiline
, stifleHistory
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as BSU
import Data.Foldable (forM_)
import Foreign
import Foreign.C.Error (eAGAIN, getErrno, resetErrno)
import Foreign.C.String
import Foreign.C.Types (CChar, CInt (..), CSize)
foreign import ccall "linenoise.h linenoise"
linenoise :: CString -> IO CString
foreign import ccall "linenoise.h linenoiseHistoryAdd"
linenoiseHistoryAdd :: Ptr CChar -> IO CInt
foreign import ccall "linenoise.h linenoiseHistorySetMaxLen"
linenoiseHistorySetMaxLen :: CInt -> IO CInt
foreign import ccall "linenoise.h linenoiseHistorySave"
linenoiseHistorySave :: CString -> IO ()
foreign import ccall "linenoise.h linenoiseHistoryLoad"
linenoiseHistoryLoad :: CString -> IO ()
foreign import ccall "linenoise.h linenoiseClearScreen"
linenoiseClearScreen :: IO ()
foreign import ccall "linenoise.h linenoiseSetMultiLine"
linenoiseSetMultiLine :: CInt -> IO ()
foreign import ccall "linenoise.h linenoisePrintKeyCodes"
linenoisePrintKeyCodes :: IO ()
foreign import ccall "linenoise.h linenoiseSetCompletionCallback"
linenoiseSetCompletionCallback :: FunPtr CompleteFunc -> IO ()
foreign import ccall "linenoise.h linenoiseAddCompletion"
linenoiseAddCompletion :: Completion -> CString -> IO ()
foreign import ccall "wrapper"
makeFunPtr :: CompleteFunc -> IO (FunPtr CompleteFunc)
data CompletionType = CompletionType CSize (Ptr (Ptr CChar))
deriving (Show, Eq)
type Completion = Ptr CompletionType
instance Storable CompletionType where
sizeOf _ = 8
alignment = sizeOf
peek ptr = do
a <- peekByteOff ptr 0
b <- peekByteOff ptr 4
pure (CompletionType a b)
poke = error "no poke"
type CompleteFunc = (CString -> Completion -> IO ())
makeCompletion :: (ByteString -> IO [ByteString]) -> (CString -> Completion -> IO ())
makeCompletion f buf lc = do
line <- BSU.unsafePackCString buf
comps <- f line
forM_ comps (`BSU.unsafeUseAsCString` linenoiseAddCompletion lc)
data InputResult a
= InterruptResult
| EofResult
| LineResult !a
deriving (Eq, Show, Functor, Foldable, Traversable)
getInputLine :: ByteString -> IO (InputResult ByteString)
getInputLine prompt = do
res <- BSU.unsafeUseAsCString prompt $ \str -> do
ptr <- linenoise str
maybePeek BSU.unsafePackCString ptr
errno <- getErrno
if errno == eAGAIN
then resetErrno >> pure InterruptResult
else pure (maybe EofResult LineResult res)
addHistory :: ByteString -> IO ()
addHistory =
flip BSU.unsafeUseAsCString $ \str -> do
_ <- linenoiseHistoryAdd str
pure ()
stifleHistory :: Int -> IO ()
stifleHistory len = do
_ <- linenoiseHistorySetMaxLen $ fromIntegral len
pure ()
historySave :: FilePath -> IO ()
historySave fname = do
str <- newCString fname
linenoiseHistorySave str
historyLoad :: FilePath -> IO ()
historyLoad fname = do
str <- newCString fname
linenoiseHistoryLoad str
clearScreen :: IO ()
clearScreen = linenoiseClearScreen
setMultiline :: Bool -> IO ()
setMultiline = linenoiseSetMultiLine . fromBool
printKeycodes :: IO ()
printKeycodes = linenoisePrintKeyCodes
setCompletion :: (ByteString -> IO [ByteString]) -> IO ()
setCompletion f = do
cb <- makeFunPtr (makeCompletion f)
linenoiseSetCompletionCallback cb