{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Linenoise.FFI
( InputResult (..)
, addHistory
, clearScreen
, getInputLine
, historyLoad
, historySave
, printKeycodes
, setCompletion
, setMultiline
, stifleHistory
)
where
import Control.Monad (unless)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BSU
import Data.Foldable (for_)
import Foreign (FunPtr, Ptr, Storable (..), fromBool, maybePeek)
import Foreign.C.Error (eAGAIN, getErrno, resetErrno)
import Foreign.C.String (CString, newCString)
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 (Int -> CompletionType -> ShowS
[CompletionType] -> ShowS
CompletionType -> String
(Int -> CompletionType -> ShowS)
-> (CompletionType -> String)
-> ([CompletionType] -> ShowS)
-> Show CompletionType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompletionType -> ShowS
showsPrec :: Int -> CompletionType -> ShowS
$cshow :: CompletionType -> String
show :: CompletionType -> String
$cshowList :: [CompletionType] -> ShowS
showList :: [CompletionType] -> ShowS
Show, CompletionType -> CompletionType -> Bool
(CompletionType -> CompletionType -> Bool)
-> (CompletionType -> CompletionType -> Bool) -> Eq CompletionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompletionType -> CompletionType -> Bool
== :: CompletionType -> CompletionType -> Bool
$c/= :: CompletionType -> CompletionType -> Bool
/= :: CompletionType -> CompletionType -> Bool
Eq)
type Completion = Ptr CompletionType
instance Storable CompletionType where
sizeOf :: CompletionType -> Int
sizeOf CompletionType
_ = Int
8
alignment :: CompletionType -> Int
alignment = CompletionType -> Int
forall a. Storable a => a -> Int
sizeOf
peek :: Ptr CompletionType -> IO CompletionType
peek Ptr CompletionType
ptr = do
CSize
a <- Ptr CompletionType -> Int -> IO CSize
forall b. Ptr b -> Int -> IO CSize
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CompletionType
ptr Int
0
Ptr (Ptr CChar)
b <- Ptr CompletionType -> Int -> IO (Ptr (Ptr CChar))
forall b. Ptr b -> Int -> IO (Ptr (Ptr CChar))
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CompletionType
ptr Int
4
CompletionType -> IO CompletionType
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CSize -> Ptr (Ptr CChar) -> CompletionType
CompletionType CSize
a Ptr (Ptr CChar)
b)
poke :: Ptr CompletionType -> CompletionType -> IO ()
poke = String -> Ptr CompletionType -> CompletionType -> IO ()
forall a. HasCallStack => String -> a
error String
"no poke"
type CompleteFunc = (CString -> Completion -> IO ())
makeCompletion :: (ByteString -> IO [ByteString]) -> (CString -> Completion -> IO ())
makeCompletion :: (ByteString -> IO [ByteString])
-> Ptr CChar -> Ptr CompletionType -> IO ()
makeCompletion ByteString -> IO [ByteString]
f Ptr CChar
buf Ptr CompletionType
lc = do
ByteString
line <- Ptr CChar -> IO ByteString
BSU.unsafePackCString Ptr CChar
buf
[ByteString]
comps <- ByteString -> IO [ByteString]
f ByteString
line
[ByteString] -> (ByteString -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ByteString]
comps (\ByteString
c -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
c) (ByteString -> (Ptr CChar -> IO ()) -> IO ()
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BSU.unsafeUseAsCString ByteString
c (Ptr CompletionType -> Ptr CChar -> IO ()
linenoiseAddCompletion Ptr CompletionType
lc)))
data InputResult a
=
InterruptResult
|
EofResult
| LineResult !a
deriving (InputResult a -> InputResult a -> Bool
(InputResult a -> InputResult a -> Bool)
-> (InputResult a -> InputResult a -> Bool) -> Eq (InputResult a)
forall a. Eq a => InputResult a -> InputResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => InputResult a -> InputResult a -> Bool
== :: InputResult a -> InputResult a -> Bool
$c/= :: forall a. Eq a => InputResult a -> InputResult a -> Bool
/= :: InputResult a -> InputResult a -> Bool
Eq, Int -> InputResult a -> ShowS
[InputResult a] -> ShowS
InputResult a -> String
(Int -> InputResult a -> ShowS)
-> (InputResult a -> String)
-> ([InputResult a] -> ShowS)
-> Show (InputResult a)
forall a. Show a => Int -> InputResult a -> ShowS
forall a. Show a => [InputResult a] -> ShowS
forall a. Show a => InputResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> InputResult a -> ShowS
showsPrec :: Int -> InputResult a -> ShowS
$cshow :: forall a. Show a => InputResult a -> String
show :: InputResult a -> String
$cshowList :: forall a. Show a => [InputResult a] -> ShowS
showList :: [InputResult a] -> ShowS
Show, (forall a b. (a -> b) -> InputResult a -> InputResult b)
-> (forall a b. a -> InputResult b -> InputResult a)
-> Functor InputResult
forall a b. a -> InputResult b -> InputResult a
forall a b. (a -> b) -> InputResult a -> InputResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> InputResult a -> InputResult b
fmap :: forall a b. (a -> b) -> InputResult a -> InputResult b
$c<$ :: forall a b. a -> InputResult b -> InputResult a
<$ :: forall a b. a -> InputResult b -> InputResult a
Functor, (forall m. Monoid m => InputResult m -> m)
-> (forall m a. Monoid m => (a -> m) -> InputResult a -> m)
-> (forall m a. Monoid m => (a -> m) -> InputResult a -> m)
-> (forall a b. (a -> b -> b) -> b -> InputResult a -> b)
-> (forall a b. (a -> b -> b) -> b -> InputResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> InputResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> InputResult a -> b)
-> (forall a. (a -> a -> a) -> InputResult a -> a)
-> (forall a. (a -> a -> a) -> InputResult a -> a)
-> (forall a. InputResult a -> [a])
-> (forall a. InputResult a -> Bool)
-> (forall a. InputResult a -> Int)
-> (forall a. Eq a => a -> InputResult a -> Bool)
-> (forall a. Ord a => InputResult a -> a)
-> (forall a. Ord a => InputResult a -> a)
-> (forall a. Num a => InputResult a -> a)
-> (forall a. Num a => InputResult a -> a)
-> Foldable InputResult
forall a. Eq a => a -> InputResult a -> Bool
forall a. Num a => InputResult a -> a
forall a. Ord a => InputResult a -> a
forall m. Monoid m => InputResult m -> m
forall a. InputResult a -> Bool
forall a. InputResult a -> Int
forall a. InputResult a -> [a]
forall a. (a -> a -> a) -> InputResult a -> a
forall m a. Monoid m => (a -> m) -> InputResult a -> m
forall b a. (b -> a -> b) -> b -> InputResult a -> b
forall a b. (a -> b -> b) -> b -> InputResult a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => InputResult m -> m
fold :: forall m. Monoid m => InputResult m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> InputResult a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> InputResult a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> InputResult a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> InputResult a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> InputResult a -> b
foldr :: forall a b. (a -> b -> b) -> b -> InputResult a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> InputResult a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> InputResult a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> InputResult a -> b
foldl :: forall b a. (b -> a -> b) -> b -> InputResult a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> InputResult a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> InputResult a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> InputResult a -> a
foldr1 :: forall a. (a -> a -> a) -> InputResult a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> InputResult a -> a
foldl1 :: forall a. (a -> a -> a) -> InputResult a -> a
$ctoList :: forall a. InputResult a -> [a]
toList :: forall a. InputResult a -> [a]
$cnull :: forall a. InputResult a -> Bool
null :: forall a. InputResult a -> Bool
$clength :: forall a. InputResult a -> Int
length :: forall a. InputResult a -> Int
$celem :: forall a. Eq a => a -> InputResult a -> Bool
elem :: forall a. Eq a => a -> InputResult a -> Bool
$cmaximum :: forall a. Ord a => InputResult a -> a
maximum :: forall a. Ord a => InputResult a -> a
$cminimum :: forall a. Ord a => InputResult a -> a
minimum :: forall a. Ord a => InputResult a -> a
$csum :: forall a. Num a => InputResult a -> a
sum :: forall a. Num a => InputResult a -> a
$cproduct :: forall a. Num a => InputResult a -> a
product :: forall a. Num a => InputResult a -> a
Foldable, Functor InputResult
Foldable InputResult
(Functor InputResult, Foldable InputResult) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> InputResult a -> f (InputResult b))
-> (forall (f :: * -> *) a.
Applicative f =>
InputResult (f a) -> f (InputResult a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> InputResult a -> m (InputResult b))
-> (forall (m :: * -> *) a.
Monad m =>
InputResult (m a) -> m (InputResult a))
-> Traversable InputResult
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
InputResult (m a) -> m (InputResult a)
forall (f :: * -> *) a.
Applicative f =>
InputResult (f a) -> f (InputResult a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> InputResult a -> m (InputResult b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> InputResult a -> f (InputResult b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> InputResult a -> f (InputResult b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> InputResult a -> f (InputResult b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
InputResult (f a) -> f (InputResult a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
InputResult (f a) -> f (InputResult a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> InputResult a -> m (InputResult b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> InputResult a -> m (InputResult b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
InputResult (m a) -> m (InputResult a)
sequence :: forall (m :: * -> *) a.
Monad m =>
InputResult (m a) -> m (InputResult a)
Traversable)
getInputLine :: ByteString -> IO (InputResult ByteString)
getInputLine :: ByteString -> IO (InputResult ByteString)
getInputLine ByteString
prompt = do
Maybe ByteString
res <- ByteString
-> (Ptr CChar -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BSU.unsafeUseAsCString ByteString
prompt ((Ptr CChar -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (Ptr CChar -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
str -> do
Ptr CChar
ptr <- Ptr CChar -> IO (Ptr CChar)
linenoise Ptr CChar
str
(Ptr CChar -> IO ByteString) -> Ptr CChar -> IO (Maybe ByteString)
forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek Ptr CChar -> IO ByteString
BSU.unsafePackCString Ptr CChar
ptr
Errno
errno <- IO Errno
getErrno
if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eAGAIN
then IO ()
resetErrno IO () -> IO (InputResult ByteString) -> IO (InputResult ByteString)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InputResult ByteString -> IO (InputResult ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InputResult ByteString
forall a. InputResult a
InterruptResult
else InputResult ByteString -> IO (InputResult ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InputResult ByteString
-> (ByteString -> InputResult ByteString)
-> Maybe ByteString
-> InputResult ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe InputResult ByteString
forall a. InputResult a
EofResult ByteString -> InputResult ByteString
forall a. a -> InputResult a
LineResult Maybe ByteString
res)
addHistory :: ByteString -> IO ()
addHistory :: ByteString -> IO ()
addHistory ByteString
bs =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> (Ptr CChar -> IO ()) -> IO ()
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BSU.unsafeUseAsCString ByteString
bs ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
str -> do
CInt
_ <- Ptr CChar -> IO CInt
linenoiseHistoryAdd Ptr CChar
str
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
stifleHistory :: Int -> IO ()
stifleHistory :: Int -> IO ()
stifleHistory Int
len = do
CInt
_ <- CInt -> IO CInt
linenoiseHistorySetMaxLen (CInt -> IO CInt) -> CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
historySave :: FilePath -> IO ()
historySave :: String -> IO ()
historySave String
fname = do
Ptr CChar
str <- String -> IO (Ptr CChar)
newCString String
fname
Ptr CChar -> IO ()
linenoiseHistorySave Ptr CChar
str
historyLoad :: FilePath -> IO ()
historyLoad :: String -> IO ()
historyLoad String
fname = do
Ptr CChar
str <- String -> IO (Ptr CChar)
newCString String
fname
Ptr CChar -> IO ()
linenoiseHistoryLoad Ptr CChar
str
clearScreen :: IO ()
clearScreen :: IO ()
clearScreen = IO ()
linenoiseClearScreen
setMultiline :: Bool -> IO ()
setMultiline :: Bool -> IO ()
setMultiline = CInt -> IO ()
linenoiseSetMultiLine (CInt -> IO ()) -> (Bool -> CInt) -> Bool -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> CInt
forall a. Num a => Bool -> a
fromBool
printKeycodes :: IO ()
printKeycodes :: IO ()
printKeycodes = IO ()
linenoisePrintKeyCodes
setCompletion :: (ByteString -> IO [ByteString]) -> IO ()
setCompletion :: (ByteString -> IO [ByteString]) -> IO ()
setCompletion ByteString -> IO [ByteString]
f = do
FunPtr (Ptr CChar -> Ptr CompletionType -> IO ())
cb <- (Ptr CChar -> Ptr CompletionType -> IO ())
-> IO (FunPtr (Ptr CChar -> Ptr CompletionType -> IO ()))
makeFunPtr ((ByteString -> IO [ByteString])
-> Ptr CChar -> Ptr CompletionType -> IO ()
makeCompletion ByteString -> IO [ByteString]
f)
FunPtr (Ptr CChar -> Ptr CompletionType -> IO ()) -> IO ()
linenoiseSetCompletionCallback FunPtr (Ptr CChar -> Ptr CompletionType -> IO ())
cb