----------------------------------------------------------------------------
-- |
-- Module      :  Emacs.Module.Functions
-- Copyright   :  (c) Sergey Vinokurov 2018
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
--
-- Wrappers around some Emacs functions, independent of concrete monad.
----------------------------------------------------------------------------

{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE RankNTypes          #-}

module Emacs.Module.Functions
  ( bindFunction
  , makeFunction
  , withCleanup
  , provide
  , makeUserPtrFromStablePtr
  , extractStablePtrFromUserPtr
    -- * Haskell<->Emacs datatype conversions
  , extractInt
  , makeInt
  , extractText
  , makeText
  , extractShortByteString
  , makeShortByteString
  , extractBool
  , makeBool
    -- * Vectors
  , extractVector
  , extractVectorWith
  , extractUnboxedVectorWith
  , makeVector
  , vconcat2
    -- * Lists
  , cons
  , car
  , cdr
  , nil
  , setcar
  , setcdr
  , makeList
  , extractList
  , extractListWith
  , extractListRevWith
  , foldlEmacsListWith
  , unfoldEmacsListWith
    -- * Strings
  , addFaceProp
  , propertize
  , concat2
  , valueToText
  , symbolName

    -- * Reexports
  , MonadMask
  ) where

import Control.Monad.Catch
import Control.Monad.Except

import Data.ByteString.Char8 qualified as C8
import Data.ByteString.Short (ShortByteString)
import Data.ByteString.Short qualified as BSS
import Data.Foldable
import Data.Text (Text)
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error qualified as TE
import Data.Vector qualified as V
import Data.Vector.Unboxed qualified as U
import Foreign.Ptr (nullPtr)
import Foreign.StablePtr

import Data.Emacs.Module.Args
import Data.Emacs.Module.Env qualified as Env
import Data.Emacs.Module.SymbolName (SymbolName)
import Data.Emacs.Module.SymbolName.TH
import Emacs.Module.Assert
import Emacs.Module.Monad.Class


{-# INLINABLE bindFunction #-}
-- | Assign a name to function value.
bindFunction
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => SymbolName   -- ^ Name
  -> EmacsRef m s -- ^ Function value
  -> m s ()
bindFunction :: SymbolName -> EmacsRef m s -> m s ()
bindFunction SymbolName
name EmacsRef m s
def = do
  EmacsRef m s
name' <- SymbolName -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> m s (EmacsRef m s)
intern SymbolName
name
  SymbolName -> [EmacsRef m s] -> m s ()
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s ()
funcallPrimitive_ [esym|fset|] [EmacsRef m s
name', EmacsRef m s
def]

{-# INLINE makeFunction #-}
-- | Make Haskell function available as an anonymoucs Emacs
-- function. In order to be able to use it later from Emacs it should
-- be fed into 'bindFunction'.
--
-- This is a simplified version of 'makeFunctionExtra'.
makeFunction
  :: (WithCallStack, EmacsInvocation req opt rest, GetArities req opt rest, MonadEmacs m, Monad (m s))
  => (forall s'. EmacsFunction req opt rest s' m)
  -> C8.ByteString
  -> m s (EmacsRef m s)
makeFunction :: (forall s'. EmacsFunction req opt rest s' m)
-> ByteString -> m s (EmacsRef m s)
makeFunction forall s'. EmacsFunction req opt rest s' m
f ByteString
doc =
  (forall s'. EmacsFunctionExtra req opt rest Any s' m)
-> ByteString -> Ptr Any -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (req :: Nat) (opt :: Nat)
       (rest :: Bool) extra (s :: k).
(MonadEmacs m, WithCallStack, EmacsInvocation req opt rest,
 GetArities req opt rest) =>
(forall (s' :: k). EmacsFunctionExtra req opt rest extra s' m)
-> ByteString -> Ptr extra -> m s (EmacsRef m s)
makeFunctionExtra (\EmacsArgs req opt rest (EmacsRef m s')
env Ptr Any
_extraPtr -> EmacsArgs req opt rest (EmacsRef m s') -> m s' (EmacsReturn m s')
forall s'. EmacsFunction req opt rest s' m
f EmacsArgs req opt rest (EmacsRef m s')
env) ByteString
doc Ptr Any
forall a. Ptr a
nullPtr

{-# INLINE provide #-}
-- | Signal to Emacs that certain feature is being provided. Returns provided
-- symbol.
provide
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => SymbolName -- ^ Feature to provide
  -> m s ()
provide :: SymbolName -> m s ()
provide SymbolName
sym = do
  EmacsRef m s
sym' <- SymbolName -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> m s (EmacsRef m s)
intern SymbolName
sym
  SymbolName -> [EmacsRef m s] -> m s ()
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s ()
funcallPrimitive_ [esym|provide|] [EmacsRef m s
sym']

{-# INLINE makeUserPtrFromStablePtr #-}
-- | Pack a stable pointer as Emacs @user_ptr@.
makeUserPtrFromStablePtr
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => StablePtr a
  -> m s (EmacsRef m s)
makeUserPtrFromStablePtr :: StablePtr a -> m s (EmacsRef m s)
makeUserPtrFromStablePtr =
  UserPtrFinaliser () -> Ptr () -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) a (s :: k).
(MonadEmacs m, WithCallStack) =>
UserPtrFinaliser a -> Ptr a -> m s (EmacsRef m s)
makeUserPtr UserPtrFinaliser ()
forall a. UserPtrFinaliser a
Env.freeStablePtrFinaliser (Ptr () -> m s (EmacsRef m s))
-> (StablePtr a -> Ptr ()) -> StablePtr a -> m s (EmacsRef m s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StablePtr a -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr

{-# INLINE extractStablePtrFromUserPtr #-}
extractStablePtrFromUserPtr
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s
  -> m s (StablePtr a)
extractStablePtrFromUserPtr :: EmacsRef m s -> m s (StablePtr a)
extractStablePtrFromUserPtr =
  (Ptr () -> StablePtr a) -> m s (Ptr ()) -> m s (StablePtr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ptr () -> StablePtr a
forall a. Ptr () -> StablePtr a
castPtrToStablePtr (m s (Ptr ()) -> m s (StablePtr a))
-> (EmacsRef m s -> m s (Ptr ()))
-> EmacsRef m s
-> m s (StablePtr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmacsRef m s -> m s (Ptr ())
forall k (m :: k -> * -> *) (s :: k) a.
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s (Ptr a)
extractUserPtr

{-# INLINE extractInt #-}
-- | Try to obtain an 'Int' from Emacs value.
--
-- This function will fail if Emacs value is not an integer or
-- contains value too big to fit into 'Int' on current architecture.
extractInt
  :: (WithCallStack, MonadEmacs m, Monad (m s)) => EmacsRef m s -> m s Int
extractInt :: EmacsRef m s -> m s Int
extractInt EmacsRef m s
x = do
  Int64
y <- EmacsRef m s -> m s Int64
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s Int64
extractWideInteger EmacsRef m s
x
  Bool -> [Char] -> m s Int -> m s Int
forall a. Bool -> [Char] -> a -> a
emacsAssert
    (Int64
y Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int))
    ([Char]
"Integer is too wide to fit into Int: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int64 -> [Char]
forall a. Show a => a -> [Char]
show Int64
y)
    (Int -> m s Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
y))

{-# INLINE makeInt #-}
-- | Pack an 'Int' integer for Emacs.
makeInt
  :: (WithCallStack, MonadEmacs m, Monad (m s)) => Int -> m s (EmacsRef m s)
makeInt :: Int -> m s (EmacsRef m s)
makeInt = Int64 -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
Int64 -> m s (EmacsRef m s)
makeWideInteger (Int64 -> m s (EmacsRef m s))
-> (Int -> Int64) -> Int -> m s (EmacsRef m s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

{-# INLINE extractText #-}
-- | Extract string contents as 'Text' from an Emacs value.
extractText
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s -> m s Text
extractText :: EmacsRef m s -> m s Text
extractText EmacsRef m s
x = OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode (ByteString -> Text) -> m s ByteString -> m s Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EmacsRef m s -> m s ByteString
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s ByteString
extractString EmacsRef m s
x

{-# INLINE makeText #-}
-- | Convert a Text into an Emacs string value.
makeText
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => Text -> m s (EmacsRef m s)
makeText :: Text -> m s (EmacsRef m s)
makeText = ByteString -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
ByteString -> m s (EmacsRef m s)
makeString (ByteString -> m s (EmacsRef m s))
-> (Text -> ByteString) -> Text -> m s (EmacsRef m s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8


{-# INLINE extractShortByteString #-}
-- | Extract string contents as 'ShortByteString' from an Emacs value.
extractShortByteString
  :: (WithCallStack, MonadEmacs m, Functor (m s))
  => EmacsRef m s -> m s ShortByteString
extractShortByteString :: EmacsRef m s -> m s ShortByteString
extractShortByteString = (ByteString -> ShortByteString)
-> m s ByteString -> m s ShortByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ShortByteString
BSS.toShort (m s ByteString -> m s ShortByteString)
-> (EmacsRef m s -> m s ByteString)
-> EmacsRef m s
-> m s ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmacsRef m s -> m s ByteString
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s ByteString
extractString

{-# INLINE makeShortByteString #-}
-- | Convert a ShortByteString into an Emacs string value.
makeShortByteString
  :: (WithCallStack, MonadEmacs m)
  => ShortByteString -> m s (EmacsRef m s)
makeShortByteString :: ShortByteString -> m s (EmacsRef m s)
makeShortByteString = ByteString -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
ByteString -> m s (EmacsRef m s)
makeString (ByteString -> m s (EmacsRef m s))
-> (ShortByteString -> ByteString)
-> ShortByteString
-> m s (EmacsRef m s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
BSS.fromShort


{-# INLINE extractBool #-}
-- | Extract a boolean from an Emacs value.
extractBool
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s -> m s Bool
extractBool :: EmacsRef m s -> m s Bool
extractBool = EmacsRef m s -> m s Bool
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s Bool
isNotNil

{-# INLINE makeBool #-}
-- | Convert a Bool into an Emacs string value.
makeBool
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => Bool -> m s (EmacsRef m s)
makeBool :: Bool -> m s (EmacsRef m s)
makeBool Bool
b = SymbolName -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> m s (EmacsRef m s)
intern (if Bool
b then [esym|t|] else [esym|nil|])

{-# INLINE withCleanup #-}
-- | Feed a value into a function and clean it up afterwards.
withCleanup
  :: (WithCallStack, MonadMask (m s), MonadEmacs m, Monad (m s))
  => EmacsRef m s
  -> (EmacsRef m s -> m s a)
  -> m s a
withCleanup :: EmacsRef m s -> (EmacsRef m s -> m s a) -> m s a
withCleanup EmacsRef m s
x EmacsRef m s -> m s a
f = EmacsRef m s -> m s a
f EmacsRef m s
x m s a -> m s () -> m s a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` EmacsRef m s -> m s ()
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s ()
freeValue EmacsRef m s
x

{-# INLINABLE extractVector #-}
-- | Get all elements form an Emacs vector.
extractVector
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s -> m s (V.Vector (EmacsRef m s))
extractVector :: EmacsRef m s -> m s (Vector (EmacsRef m s))
extractVector EmacsRef m s
xs = do
  Int
n <- EmacsRef m s -> m s Int
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s Int
vecSize EmacsRef m s
xs
  Int -> (Int -> m s (EmacsRef m s)) -> m s (Vector (EmacsRef m s))
forall (m :: * -> *) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
V.generateM Int
n ((Int -> m s (EmacsRef m s)) -> m s (Vector (EmacsRef m s)))
-> (Int -> m s (EmacsRef m s)) -> m s (Vector (EmacsRef m s))
forall a b. (a -> b) -> a -> b
$ EmacsRef m s -> Int -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> Int -> m s (EmacsRef m s)
vecGet EmacsRef m s
xs

{-# INLINABLE extractVectorWith #-}
-- | Get all elements form an Emacs vector using specific function to
-- convert elements.
extractVectorWith
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => (EmacsRef m s -> m s a)
  -> EmacsRef m s
  -> m s (V.Vector a)
extractVectorWith :: (EmacsRef m s -> m s a) -> EmacsRef m s -> m s (Vector a)
extractVectorWith EmacsRef m s -> m s a
f EmacsRef m s
xs = do
  Int
n <- EmacsRef m s -> m s Int
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s Int
vecSize EmacsRef m s
xs
  Int -> (Int -> m s a) -> m s (Vector a)
forall (m :: * -> *) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
V.generateM Int
n ((Int -> m s a) -> m s (Vector a))
-> (Int -> m s a) -> m s (Vector a)
forall a b. (a -> b) -> a -> b
$ EmacsRef m s -> m s a
f (EmacsRef m s -> m s a)
-> (Int -> m s (EmacsRef m s)) -> Int -> m s a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< EmacsRef m s -> Int -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> Int -> m s (EmacsRef m s)
vecGet EmacsRef m s
xs

{-# INLINABLE extractUnboxedVectorWith #-}
-- | Get all elements form an Emacs vector using specific function to
-- convert elements.
extractUnboxedVectorWith
  :: (WithCallStack, MonadEmacs m, Monad (m s), U.Unbox a)
  => (EmacsRef m s -> m s a)
  -> EmacsRef m s
  -> m s (U.Vector a)
extractUnboxedVectorWith :: (EmacsRef m s -> m s a) -> EmacsRef m s -> m s (Vector a)
extractUnboxedVectorWith EmacsRef m s -> m s a
f EmacsRef m s
xs = do
  Int
n <- EmacsRef m s -> m s Int
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s Int
vecSize EmacsRef m s
xs
  Int -> (Int -> m s a) -> m s (Vector a)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> (Int -> m a) -> m (Vector a)
U.generateM Int
n ((Int -> m s a) -> m s (Vector a))
-> (Int -> m s a) -> m s (Vector a)
forall a b. (a -> b) -> a -> b
$ EmacsRef m s -> m s a
f (EmacsRef m s -> m s a)
-> (Int -> m s (EmacsRef m s)) -> Int -> m s a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< EmacsRef m s -> Int -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> Int -> m s (EmacsRef m s)
vecGet EmacsRef m s
xs

{-# INLINE makeVector #-}
-- | Create an Emacs vector.
makeVector
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => [EmacsRef m s]
  -> m s (EmacsRef m s)
makeVector :: [EmacsRef m s] -> m s (EmacsRef m s)
makeVector = SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
funcallPrimitive [esym|vector|]

{-# INLINE vconcat2 #-}
-- | Concatenate two vectors.
vconcat2
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s
  -> EmacsRef m s
  -> m s (EmacsRef m s)
vconcat2 :: EmacsRef m s -> EmacsRef m s -> m s (EmacsRef m s)
vconcat2 EmacsRef m s
x EmacsRef m s
y =
  SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
funcallPrimitive [esym|vconcat|] [EmacsRef m s
x, EmacsRef m s
y]

{-# INLINE cons #-}
-- | Make a cons pair out of two values.
cons
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s -- ^ car
  -> EmacsRef m s -- ^ cdr
  -> m s (EmacsRef m s)
cons :: EmacsRef m s -> EmacsRef m s -> m s (EmacsRef m s)
cons EmacsRef m s
x EmacsRef m s
y = SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
funcallPrimitive [esym|cons|] [EmacsRef m s
x, EmacsRef m s
y]

{-# INLINE car #-}
-- | Take first element of a pair.
car
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s
  -> m s (EmacsRef m s)
car :: EmacsRef m s -> m s (EmacsRef m s)
car = SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
funcallPrimitive [esym|car|] ([EmacsRef m s] -> m s (EmacsRef m s))
-> (EmacsRef m s -> [EmacsRef m s])
-> EmacsRef m s
-> m s (EmacsRef m s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EmacsRef m s -> [EmacsRef m s] -> [EmacsRef m s]
forall a. a -> [a] -> [a]
: [])

{-# INLINE cdr #-}
-- | Take second element of a pair.
cdr
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s
  -> m s (EmacsRef m s)
cdr :: EmacsRef m s -> m s (EmacsRef m s)
cdr = SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
funcallPrimitive [esym|cdr|] ([EmacsRef m s] -> m s (EmacsRef m s))
-> (EmacsRef m s -> [EmacsRef m s])
-> EmacsRef m s
-> m s (EmacsRef m s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EmacsRef m s -> [EmacsRef m s] -> [EmacsRef m s]
forall a. a -> [a] -> [a]
: [])

{-# INLINE nil #-}
-- | A @nil@ symbol aka empty list.
nil
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => m s (EmacsRef m s)
nil :: m s (EmacsRef m s)
nil = SymbolName -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> m s (EmacsRef m s)
intern [esym|nil|]

{-# INLINE setcar #-}
-- | Mutate first element of a cons pair.
setcar
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s -- ^ Cons pair
  -> EmacsRef m s -- ^ New value
  -> m s ()
setcar :: EmacsRef m s -> EmacsRef m s -> m s ()
setcar EmacsRef m s
x EmacsRef m s
y = SymbolName -> [EmacsRef m s] -> m s ()
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s ()
funcallPrimitive_ [esym|setcar|] [EmacsRef m s
x, EmacsRef m s
y]

{-# INLINE setcdr #-}
-- | Mutate second element of a cons pair.
setcdr
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s -- ^ Cons pair
  -> EmacsRef m s -- ^ New value
  -> m s ()
setcdr :: EmacsRef m s -> EmacsRef m s -> m s ()
setcdr EmacsRef m s
x EmacsRef m s
y = SymbolName -> [EmacsRef m s] -> m s ()
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s ()
funcallPrimitive_ [esym|setcdr|] [EmacsRef m s
x, EmacsRef m s
y]

{-# INLINE makeList #-}
-- | Construct vanilla Emacs list from a Haskell list.
makeList
  :: (WithCallStack, MonadEmacs m, Monad (m s), Foldable f)
  => f (EmacsRef m s)
  -> m s (EmacsRef m s)
makeList :: f (EmacsRef m s) -> m s (EmacsRef m s)
makeList = ([EmacsRef m s] -> m s (Maybe (EmacsRef m s, [EmacsRef m s])))
-> [EmacsRef m s] -> m s (EmacsRef m s)
forall (m :: * -> * -> *) s a.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
(a -> m s (Maybe (EmacsRef m s, a))) -> a -> m s (EmacsRef m s)
unfoldEmacsListWith (Maybe (EmacsRef m s, [EmacsRef m s])
-> m s (Maybe (EmacsRef m s, [EmacsRef m s]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EmacsRef m s, [EmacsRef m s])
 -> m s (Maybe (EmacsRef m s, [EmacsRef m s])))
-> ([EmacsRef m s] -> Maybe (EmacsRef m s, [EmacsRef m s]))
-> [EmacsRef m s]
-> m s (Maybe (EmacsRef m s, [EmacsRef m s]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EmacsRef m s] -> Maybe (EmacsRef m s, [EmacsRef m s])
forall a. [a] -> Maybe (a, [a])
go) ([EmacsRef m s] -> m s (EmacsRef m s))
-> (f (EmacsRef m s) -> [EmacsRef m s])
-> f (EmacsRef m s)
-> m s (EmacsRef m s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (EmacsRef m s) -> [EmacsRef m s]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where
    go :: [a] -> Maybe (a, [a])
go = \case
      []     -> Maybe (a, [a])
forall a. Maybe a
Nothing
      a
y : [a]
ys -> (a, [a]) -> Maybe (a, [a])
forall a. a -> Maybe a
Just (a
y, [a]
ys)

{-# INLINE extractList #-}
-- | Extract vanilla Emacs list as Haskell list.
extractList
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s
  -> m s [EmacsRef m s]
extractList :: EmacsRef m s -> m s [EmacsRef m s]
extractList = (EmacsRef m s -> m s (EmacsRef m s))
-> EmacsRef m s -> m s [EmacsRef m s]
forall (m :: * -> * -> *) s a.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
(EmacsRef m s -> m s a) -> EmacsRef m s -> m s [a]
extractListWith EmacsRef m s -> m s (EmacsRef m s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

{-# INLINE extractListWith #-}
-- | Extract vanilla Emacs list as a Haskell list.
extractListWith
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => (EmacsRef m s -> m s a)
  -> EmacsRef m s
  -> m s [a]
extractListWith :: (EmacsRef m s -> m s a) -> EmacsRef m s -> m s [a]
extractListWith = \EmacsRef m s -> m s a
f -> ([a] -> [a]) -> m s [a] -> m s [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> [a]
forall a. [a] -> [a]
reverse (m s [a] -> m s [a])
-> (EmacsRef m s -> m s [a]) -> EmacsRef m s -> m s [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EmacsRef m s -> m s a) -> EmacsRef m s -> m s [a]
forall (m :: * -> * -> *) s a.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
(EmacsRef m s -> m s a) -> EmacsRef m s -> m s [a]
extractListRevWith EmacsRef m s -> m s a
f

{-# INLINE extractListRevWith #-}
-- | Extract vanilla Emacs list as a reversed Haskell list. It's more
-- efficient than 'extractList' but doesn't preserve order of elements
-- that was specified from Emacs side.
extractListRevWith
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => (EmacsRef m s -> m s a)
  -> EmacsRef m s
  -> m s [a]
extractListRevWith :: (EmacsRef m s -> m s a) -> EmacsRef m s -> m s [a]
extractListRevWith EmacsRef m s -> m s a
f = [a] -> EmacsRef m s -> m s [a]
go []
  where
    go :: [a] -> EmacsRef m s -> m s [a]
go [a]
acc EmacsRef m s
xs = do
      Bool
nonNil <- EmacsRef m s -> m s Bool
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s Bool
isNotNil EmacsRef m s
xs
      if Bool
nonNil
        then do
          a
x   <- EmacsRef m s -> m s a
f (EmacsRef m s -> m s a) -> m s (EmacsRef m s) -> m s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EmacsRef m s -> m s (EmacsRef m s)
forall (m :: * -> * -> *) s.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
EmacsRef m s -> m s (EmacsRef m s)
car EmacsRef m s
xs
          EmacsRef m s
xs' <- EmacsRef m s -> m s (EmacsRef m s)
forall (m :: * -> * -> *) s.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
EmacsRef m s -> m s (EmacsRef m s)
cdr EmacsRef m s
xs
          [a] -> EmacsRef m s -> m s [a]
go (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc) EmacsRef m s
xs'
        else [a] -> m s [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
acc

{-# INLINE foldlEmacsListWith #-}
-- | Fold Emacs list starting from the left.
foldlEmacsListWith
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => (a -> EmacsRef m s -> m s a)
  -> a
  -> EmacsRef m s
  -> m s a
foldlEmacsListWith :: (a -> EmacsRef m s -> m s a) -> a -> EmacsRef m s -> m s a
foldlEmacsListWith a -> EmacsRef m s -> m s a
f = a -> EmacsRef m s -> m s a
go
  where
    go :: a -> EmacsRef m s -> m s a
go a
acc EmacsRef m s
xs = do
      Bool
nonNil <- EmacsRef m s -> m s Bool
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
EmacsRef m s -> m s Bool
isNotNil EmacsRef m s
xs
      if Bool
nonNil
        then do
          a
acc' <- a -> EmacsRef m s -> m s a
f a
acc (EmacsRef m s -> m s a) -> m s (EmacsRef m s) -> m s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EmacsRef m s -> m s (EmacsRef m s)
forall (m :: * -> * -> *) s.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
EmacsRef m s -> m s (EmacsRef m s)
car EmacsRef m s
xs
          a -> EmacsRef m s -> m s a
go a
acc' (EmacsRef m s -> m s a) -> m s (EmacsRef m s) -> m s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EmacsRef m s -> m s (EmacsRef m s)
forall (m :: * -> * -> *) s.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
EmacsRef m s -> m s (EmacsRef m s)
cdr EmacsRef m s
xs
        else a -> m s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
acc

{-# INLINE unfoldEmacsListWith #-}
-- | Fold Emacs list starting from the left.
unfoldEmacsListWith
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => (a -> m s (Maybe (EmacsRef m s, a)))
  -> a
  -> m s (EmacsRef m s)
unfoldEmacsListWith :: (a -> m s (Maybe (EmacsRef m s, a))) -> a -> m s (EmacsRef m s)
unfoldEmacsListWith a -> m s (Maybe (EmacsRef m s, a))
f a
accum = do
  Maybe (EmacsRef m s, a)
accum' <- a -> m s (Maybe (EmacsRef m s, a))
f a
accum
  EmacsRef m s
nilVal <- m s (EmacsRef m s)
forall (m :: * -> * -> *) s.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
m s (EmacsRef m s)
nil
  case Maybe (EmacsRef m s, a)
accum' of
    Maybe (EmacsRef m s, a)
Nothing           -> EmacsRef m s -> m s (EmacsRef m s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure EmacsRef m s
nilVal
    Just (EmacsRef m s
x, a
accum'') -> do
      EmacsRef m s
cell <- EmacsRef m s -> EmacsRef m s -> m s (EmacsRef m s)
forall (m :: * -> * -> *) s.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
EmacsRef m s -> EmacsRef m s -> m s (EmacsRef m s)
cons EmacsRef m s
x EmacsRef m s
nilVal
      EmacsRef m s -> a -> EmacsRef m s -> m s ()
go EmacsRef m s
nilVal a
accum'' EmacsRef m s
cell
      EmacsRef m s -> m s (EmacsRef m s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure EmacsRef m s
cell
  where
    go :: EmacsRef m s -> a -> EmacsRef m s -> m s ()
go EmacsRef m s
nilVal = a -> EmacsRef m s -> m s ()
go'
      where
        go' :: a -> EmacsRef m s -> m s ()
go' a
acc EmacsRef m s
cell = do
          Maybe (EmacsRef m s, a)
acc' <- a -> m s (Maybe (EmacsRef m s, a))
f a
acc
          case Maybe (EmacsRef m s, a)
acc' of
            Maybe (EmacsRef m s, a)
Nothing         -> () -> m s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just (EmacsRef m s
x, a
acc'') -> do
              EmacsRef m s
cell' <- EmacsRef m s -> EmacsRef m s -> m s (EmacsRef m s)
forall (m :: * -> * -> *) s.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
EmacsRef m s -> EmacsRef m s -> m s (EmacsRef m s)
cons EmacsRef m s
x EmacsRef m s
nilVal
              EmacsRef m s -> EmacsRef m s -> m s ()
forall (m :: * -> * -> *) s.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
EmacsRef m s -> EmacsRef m s -> m s ()
setcdr EmacsRef m s
cell EmacsRef m s
cell'
              a -> EmacsRef m s -> m s ()
go' a
acc'' EmacsRef m s
cell'

{-# INLINE addFaceProp #-}
-- | Add new 'face property to a string.
addFaceProp
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s       -- ^ String to add face to
  -> SymbolName         -- ^ Face name
  -> m s (EmacsRef m s) -- ^ Propertised string
addFaceProp :: EmacsRef m s -> SymbolName -> m s (EmacsRef m s)
addFaceProp EmacsRef m s
str SymbolName
face = do
  EmacsRef m s
face' <- SymbolName -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> m s (EmacsRef m s)
intern SymbolName
face
  EmacsRef m s -> [(SymbolName, EmacsRef m s)] -> m s (EmacsRef m s)
forall (m :: * -> * -> *) s.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
EmacsRef m s -> [(SymbolName, EmacsRef m s)] -> m s (EmacsRef m s)
propertize EmacsRef m s
str [([esym|face|], EmacsRef m s
face')]

{-# INLINE propertize #-}
-- | Add new 'face property to a string.
propertize
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s                 -- ^ String to add properties to
  -> [(SymbolName, EmacsRef m s)] -- ^ Properties
  -> m s (EmacsRef m s)           -- ^ Propertised string
propertize :: EmacsRef m s -> [(SymbolName, EmacsRef m s)] -> m s (EmacsRef m s)
propertize EmacsRef m s
str [(SymbolName, EmacsRef m s)]
props = do
  [[EmacsRef m s]]
props' <- ((SymbolName, EmacsRef m s) -> m s [EmacsRef m s])
-> [(SymbolName, EmacsRef m s)] -> m s [[EmacsRef m s]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(SymbolName
name, EmacsRef m s
val) -> (\EmacsRef m s
name' -> [EmacsRef m s
name', EmacsRef m s
val]) (EmacsRef m s -> [EmacsRef m s])
-> m s (EmacsRef m s) -> m s [EmacsRef m s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SymbolName -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> m s (EmacsRef m s)
intern SymbolName
name) [(SymbolName, EmacsRef m s)]
props
  SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
funcallPrimitive [esym|propertize|] (EmacsRef m s
str EmacsRef m s -> [EmacsRef m s] -> [EmacsRef m s]
forall a. a -> [a] -> [a]
: [[EmacsRef m s]] -> [EmacsRef m s]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[EmacsRef m s]]
props')

{-# INLINE concat2 #-}
-- | Concatenate two strings.
concat2
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s
  -> EmacsRef m s
  -> m s (EmacsRef m s)
concat2 :: EmacsRef m s -> EmacsRef m s -> m s (EmacsRef m s)
concat2 EmacsRef m s
x EmacsRef m s
y =
  SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
funcallPrimitive [esym|concat|] [EmacsRef m s
x, EmacsRef m s
y]

{-# INLINE valueToText #-}
-- | Convert an Emacs value into a string using @prin1-to-string@.
valueToText
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s
  -> m s Text
valueToText :: EmacsRef m s -> m s Text
valueToText EmacsRef m s
x =
  EmacsRef m s -> m s Text
forall (m :: * -> * -> *) s.
(WithCallStack, MonadEmacs m, Monad (m s)) =>
EmacsRef m s -> m s Text
extractText (EmacsRef m s -> m s Text) -> m s (EmacsRef m s) -> m s Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
funcallPrimitive [esym|prin1-to-string|] [EmacsRef m s
x]

{-# INLINE symbolName #-}
-- | Wrapper around Emacs @symbol-name@ function - take a symbol
-- and produce an Emacs string with its textual name.
symbolName
  :: (WithCallStack, MonadEmacs m, Monad (m s))
  => EmacsRef m s
  -> m s (EmacsRef m s)
symbolName :: EmacsRef m s -> m s (EmacsRef m s)
symbolName = SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
forall k (m :: k -> * -> *) (s :: k).
(MonadEmacs m, WithCallStack) =>
SymbolName -> [EmacsRef m s] -> m s (EmacsRef m s)
funcallPrimitive [esym|symbol-name|] ([EmacsRef m s] -> m s (EmacsRef m s))
-> (EmacsRef m s -> [EmacsRef m s])
-> EmacsRef m s
-> m s (EmacsRef m s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EmacsRef m s -> [EmacsRef m s] -> [EmacsRef m s]
forall a. a -> [a] -> [a]
:[])