{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ForeignFunctionInterface #-}

-- | Just an FFI layer over the C library.
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"

-- Completion C callback
type CompleteFunc = (CString -> Completion -> IO ())

-- Make a completion function pointer.
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)))

-- | Result of getInputLine.
data InputResult a
  = -- | ctrl+c
    InterruptResult
  | -- | ctrl+d
    EofResult
  | LineResult !a -- Possibly empty line.
  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)

-- | Run the prompt, yielding a string.
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)

-- | Add to current history.
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 ()

-- | Limit the maximum history length.
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 ()

-- | Save history to a file.
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

-- | Load history from a file.
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

-- | Clear the screen.
clearScreen :: IO ()
clearScreen :: IO ()
clearScreen = IO ()
linenoiseClearScreen

-- | Enable/Disable multiline input.
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

-- | Print keycodes.
printKeycodes :: IO ()
printKeycodes :: IO ()
printKeycodes = IO ()
linenoisePrintKeyCodes

-- | Set the current completion function.
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