----------------------------------------------------------------------------
-- |
-- 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 CPP #-}

#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
# define WINDOWS 1
#endif

module Emacs.Module.Functions
  ( funcallPrimitiveSym
  , funcallPrimitiveUncheckedSym
  , funcallPrimitiveSym_
  , bindFunction
  , provide
  , makeUserPtrFromStablePtr
  , extractStablePtrFromUserPtr
    -- * Haskell<->Emacs datatype conversions
  , extractInt
  , extractOsPath
  , makeInt
  , makeText
  , makeShortByteString
  , extractBool
  , makeBool
    -- * Vectors
  , extractVectorWith
  , extractVectorMutableWith
  , extractVectorAsPrimArrayWith
  , makeVector
  , vconcat2
    -- * Lists
  , cons
  , car
  , cdr
  , nil
  , setcar
  , setcdr
  , makeList
  , extractList
  , extractListWith
  , foldlEmacsListWith
  , unfoldEmacsListWith
    -- * Strings
  , addFaceProp
  , propertize
  , concat2
  , valueToText
  , symbolName

    -- * Reexports
  , MonadMask
  ) where

import Control.Monad
import Control.Monad.Catch
import Control.Monad.Interleave
import Control.Monad.Primitive (PrimState)
import Data.ByteString.Short (ShortByteString)
import Data.ByteString.Short qualified as BSS
import Data.Foldable
import Data.Primitive.PrimArray
import Data.Primitive.Types
import Data.Text (Text)
import Data.Text.Encoding qualified as TE
import Data.Tuple.Homogenous
import Data.Vector.Generic qualified as G
import Data.Vector.Generic.Mutable qualified as GM
import Foreign.StablePtr
import System.OsPath
import System.OsString.Internal.Types

import Data.Emacs.Module.Env qualified as Env
import Data.Emacs.Module.SymbolName
import Data.Emacs.Module.SymbolName.Predefined qualified as Sym
import Emacs.Module.Assert
import Emacs.Module.Monad.Class

-- | Call a function by its name, similar to 'funcallPrimitive'.
{-# INLINE funcallPrimitiveSym #-}
funcallPrimitiveSym
  :: (WithCallStack, MonadEmacs m v, Foldable f)
  => SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveSym :: forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveSym SymbolName
func f (v s)
args = do
  v s
func' <- SymbolName -> m s (v s)
forall (s :: k). WithCallStack => SymbolName -> m s (v s)
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
SymbolName -> m s (v s)
intern SymbolName
func
  v s -> f (v s) -> m s (v s)
forall k (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(MonadEmacs m v, WithCallStack, Foldable f) =>
v s -> f (v s) -> m s (v s)
forall (f :: * -> *) (s :: k).
(WithCallStack, Foldable f) =>
v s -> f (v s) -> m s (v s)
funcallPrimitive v s
func' f (v s)
args

-- | Call a function by its name, similar to 'funcallPrimitiveUnchecked'.
{-# INLINE funcallPrimitiveUncheckedSym #-}
funcallPrimitiveUncheckedSym
  :: (WithCallStack, MonadEmacs m v, Foldable f)
  => SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveUncheckedSym :: forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveUncheckedSym SymbolName
func f (v s)
args = do
  v s
func' <- SymbolName -> m s (v s)
forall (s :: k). WithCallStack => SymbolName -> m s (v s)
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
SymbolName -> m s (v s)
intern SymbolName
func
  v s -> f (v s) -> m s (v s)
forall k (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(MonadEmacs m v, WithCallStack, Foldable f) =>
v s -> f (v s) -> m s (v s)
forall (f :: * -> *) (s :: k).
(WithCallStack, Foldable f) =>
v s -> f (v s) -> m s (v s)
funcallPrimitiveUnchecked v s
func' f (v s)
args

-- | Call a function by its name and ignore its result, similar to 'funcallPrimitiveSym'.
{-# INLINE funcallPrimitiveSym_ #-}
funcallPrimitiveSym_
  :: (WithCallStack, MonadEmacs m v, Foldable f)
  => SymbolName -> f (v s) -> m s ()
funcallPrimitiveSym_ :: forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s ()
funcallPrimitiveSym_ SymbolName
func f (v s)
args =
  m s (v s) -> m s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m s (v s) -> m s ()) -> m s (v s) -> m s ()
forall a b. (a -> b) -> a -> b
$ SymbolName -> f (v s) -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveSym SymbolName
func f (v s)
args

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

{-# INLINE provide #-}
-- | Signal to Emacs that certain feature is being provided. Returns provided
-- symbol.
provide
  :: (WithCallStack, MonadEmacs m v)
  => SymbolName -- ^ Feature to provide
  -> m s ()
provide :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
SymbolName -> m s ()
provide SymbolName
sym = do
  v s
sym' <- SymbolName -> m s (v s)
forall (s :: k). WithCallStack => SymbolName -> m s (v s)
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
SymbolName -> m s (v s)
intern SymbolName
sym
  m s (v s) -> m s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m s (v s) -> m s ()) -> m s (v s) -> m s ()
forall a b. (a -> b) -> a -> b
$ SymbolName -> [v s] -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveUncheckedSym SymbolName
Sym.provide [v s
sym']

{-# INLINE makeUserPtrFromStablePtr #-}
-- | Pack a stable pointer as Emacs @user_ptr@.
makeUserPtrFromStablePtr
  :: (WithCallStack, MonadEmacs m v)
  => StablePtr a
  -> m s (v s)
makeUserPtrFromStablePtr :: forall {k} (m :: k -> * -> *) (v :: k -> *) a (s :: k).
(WithCallStack, MonadEmacs m v) =>
StablePtr a -> m s (v s)
makeUserPtrFromStablePtr =
  FinalizerPtr () -> Ptr () -> m s (v s)
forall a (s :: k).
WithCallStack =>
FinalizerPtr a -> Ptr a -> m s (v s)
forall k (m :: k -> * -> *) (v :: k -> *) a (s :: k).
(MonadEmacs m v, WithCallStack) =>
FinalizerPtr a -> Ptr a -> m s (v s)
makeUserPtr FinalizerPtr ()
forall a. FinalizerPtr a
Env.freeStablePtrFinaliser (Ptr () -> m s (v s))
-> (StablePtr a -> Ptr ()) -> StablePtr a -> m s (v 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 v)
  => v s
  -> m s (StablePtr a)
extractStablePtrFromUserPtr :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k) a.
(WithCallStack, MonadEmacs m v) =>
v s -> m s (StablePtr a)
extractStablePtrFromUserPtr =
  (Ptr () -> StablePtr a) -> m s (Ptr ()) -> m s (StablePtr a)
forall a b. (a -> b) -> m s a -> m s b
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))
-> (v s -> m s (Ptr ())) -> v s -> m s (StablePtr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v s -> m s (Ptr ())
forall (s :: k) a. WithCallStack => v s -> m s (Ptr a)
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k) a.
(MonadEmacs m v, WithCallStack) =>
v 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 v) => v s -> m s Int
extractInt :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s Int
extractInt v s
x = do
  Int64
y <- v s -> m s Int64
forall (s :: k). WithCallStack => v s -> m s Int64
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Int64
extractWideInteger v s
x
  Bool -> String -> m s Int -> m s Int
forall a. Bool -> String -> 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))
    (String
"Integer is too wide to fit into Int: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
y)
    (Int -> m s Int
forall a. a -> m s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
y))

extractOsPath
  :: (WithCallStack, MonadEmacs m v) => v s -> m s OsPath
extractOsPath :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s OsPath
extractOsPath v s
x = do
#ifdef WINDOWS
  OsString . WindowsString . BSS.toShort . TE.encodeUtf16LE <$> extractText x
#else
  PlatformString -> OsPath
OsString (PlatformString -> OsPath)
-> (ShortByteString -> PlatformString) -> ShortByteString -> OsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> PlatformString
PosixString (ShortByteString -> OsPath) -> m s ShortByteString -> m s OsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v s -> m s ShortByteString
forall (s :: k). WithCallStack => v s -> m s ShortByteString
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s ShortByteString
extractShortByteString v s
x
#endif

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

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

{-# INLINE makeShortByteString #-}
-- | Convert a ShortByteString into an Emacs string value.
makeShortByteString
  :: (WithCallStack, MonadEmacs m v)
  => ShortByteString -> m s (v s)
makeShortByteString :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
ShortByteString -> m s (v s)
makeShortByteString = ByteString -> m s (v s)
forall (s :: k). WithCallStack => ByteString -> m s (v s)
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
ByteString -> m s (v s)
makeString (ByteString -> m s (v s))
-> (ShortByteString -> ByteString) -> ShortByteString -> m s (v 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 v)
  => v s -> m s Bool
extractBool :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s Bool
extractBool = v s -> m s Bool
forall (s :: k). WithCallStack => v s -> m s Bool
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Bool
isNotNil

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

{-# INLINE extractVectorWith #-}
-- | Get all elements form an Emacs vector.
extractVectorWith
  :: (WithCallStack, MonadEmacs m v, G.Vector w a)
  => (v s -> m s a) -> v s -> m s (w a)
extractVectorWith :: forall {k} (m :: k -> * -> *) (v :: k -> *) (w :: * -> *) a
       (s :: k).
(WithCallStack, MonadEmacs m v, Vector w a) =>
(v s -> m s a) -> v s -> m s (w a)
extractVectorWith v s -> m s a
f v s
xs = do
  Int
n <- v s -> m s Int
forall (s :: k). WithCallStack => v s -> m s Int
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Int
vecSize v s
xs
  Int -> (Int -> m s a) -> m s (w a)
forall (m :: * -> *) (v :: * -> *) a.
(Monad m, Vector v a) =>
Int -> (Int -> m a) -> m (v a)
G.generateM Int
n ((Int -> m s a) -> m s (w a)) -> (Int -> m s a) -> m s (w a)
forall a b. (a -> b) -> a -> b
$ v s -> m s a
f (v s -> m s a) -> (Int -> m s (v s)) -> Int -> m s a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< v s -> Int -> m s (v s)
forall (s :: k). WithCallStack => v s -> Int -> m s (v s)
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> Int -> m s (v s)
unsafeVecGet v s
xs

{-# INLINE extractVectorMutableWith #-}
-- | Get all elements form an Emacs vector.
extractVectorMutableWith
  :: (WithCallStack, MonadEmacs m v, GM.MVector w a)
  => (v s -> m s a) -> v s -> m s (w (PrimState (m s)) a)
extractVectorMutableWith :: forall {k} (m :: k -> * -> *) (v :: k -> *) (w :: * -> * -> *) a
       (s :: k).
(WithCallStack, MonadEmacs m v, MVector w a) =>
(v s -> m s a) -> v s -> m s (w (PrimState (m s)) a)
extractVectorMutableWith v s -> m s a
f v s
xs = do
  Int
n <- v s -> m s Int
forall (s :: k). WithCallStack => v s -> m s Int
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Int
vecSize v s
xs
  Int -> (Int -> m s a) -> m s (w (PrimState (m s)) a)
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
Int -> (Int -> m a) -> m (v (PrimState m) a)
GM.generateM Int
n ((Int -> m s a) -> m s (w (PrimState (m s)) a))
-> (Int -> m s a) -> m s (w (PrimState (m s)) a)
forall a b. (a -> b) -> a -> b
$ v s -> m s a
f (v s -> m s a) -> (Int -> m s (v s)) -> Int -> m s a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< v s -> Int -> m s (v s)
forall (s :: k). WithCallStack => v s -> Int -> m s (v s)
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> Int -> m s (v s)
unsafeVecGet v s
xs

{-# INLINE extractVectorAsPrimArrayWith #-}
-- | Get all elements form an Emacs vector.
extractVectorAsPrimArrayWith
  :: (WithCallStack, MonadEmacs m v, Prim a)
  => (v s -> m s a) -> v s -> m s (PrimArray a)
extractVectorAsPrimArrayWith :: forall {k} (m :: k -> * -> *) (v :: k -> *) a (s :: k).
(WithCallStack, MonadEmacs m v, Prim a) =>
(v s -> m s a) -> v s -> m s (PrimArray a)
extractVectorAsPrimArrayWith v s -> m s a
f v s
xs = do
  Int
n <- v s -> m s Int
forall (s :: k). WithCallStack => v s -> m s Int
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Int
vecSize v s
xs
  Int -> (Int -> m s a) -> m s (PrimArray a)
forall (f :: * -> *) a.
(Applicative f, Prim a) =>
Int -> (Int -> f a) -> f (PrimArray a)
generatePrimArrayA Int
n ((Int -> m s a) -> m s (PrimArray a))
-> (Int -> m s a) -> m s (PrimArray a)
forall a b. (a -> b) -> a -> b
$ v s -> m s a
f (v s -> m s a) -> (Int -> m s (v s)) -> Int -> m s a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< v s -> Int -> m s (v s)
forall (s :: k). WithCallStack => v s -> Int -> m s (v s)
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> Int -> m s (v s)
unsafeVecGet v s
xs

{-# INLINE makeVector #-}
-- | Create an Emacs vector.
makeVector
  :: (WithCallStack, MonadEmacs m v, Foldable f)
  => f (v s)
  -> m s (v s)
makeVector :: forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
f (v s) -> m s (v s)
makeVector = SymbolName -> f (v s) -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveUncheckedSym SymbolName
Sym.vector

{-# INLINE vconcat2 #-}
-- | Concatenate two vectors.
vconcat2
  :: (WithCallStack, MonadEmacs m v)
  => v s
  -> v s
  -> m s (v s)
vconcat2 :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> v s -> m s (v s)
vconcat2 v s
x v s
y =
  SymbolName -> Tuple2 (v s) -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveSym SymbolName
Sym.vconcat ((v s, v s) -> Tuple2 (v s)
forall a. (a, a) -> Tuple2 a
Tuple2 (v s
x, v s
y))

{-# INLINE cons #-}
-- | Make a cons pair out of two values.
cons
  :: (WithCallStack, MonadEmacs m v)
  => v s -- ^ car
  -> v s -- ^ cdr
  -> m s (v s)
cons :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> v s -> m s (v s)
cons v s
x v s
y = SymbolName -> Tuple2 (v s) -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveUncheckedSym SymbolName
Sym.cons ((v s, v s) -> Tuple2 (v s)
forall a. (a, a) -> Tuple2 a
Tuple2 (v s
x, v s
y))

{-# INLINE car #-}
-- | Take first element of a pair.

car
  :: (WithCallStack, MonadEmacs m v)
  => v s
  -> m s (v s)
car :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s (v s)
car = SymbolName -> Tuple1 (v s) -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveUncheckedSym SymbolName
Sym.car (Tuple1 (v s) -> m s (v s))
-> (v s -> Tuple1 (v s)) -> v s -> m s (v s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v s -> Tuple1 (v s)
forall a. a -> Tuple1 a
Tuple1

{-# INLINE cdr #-}
-- | Take second element of a pair.
cdr
  :: (WithCallStack, MonadEmacs m v)
  => v s
  -> m s (v s)
cdr :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s (v s)
cdr = SymbolName -> Tuple1 (v s) -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveUncheckedSym SymbolName
Sym.cdr (Tuple1 (v s) -> m s (v s))
-> (v s -> Tuple1 (v s)) -> v s -> m s (v s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v s -> Tuple1 (v s)
forall a. a -> Tuple1 a
Tuple1

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

{-# INLINE setcar #-}
-- | Mutate first element of a cons pair.
setcar
  :: (WithCallStack, MonadEmacs m v)
  => v s -- ^ Cons pair
  -> v s -- ^ New value
  -> m s ()
setcar :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> v s -> m s ()
setcar v s
x v s
y = SymbolName -> Tuple2 (v s) -> m s ()
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s ()
funcallPrimitiveSym_ SymbolName
Sym.setcar ((v s, v s) -> Tuple2 (v s)
forall a. (a, a) -> Tuple2 a
Tuple2 (v s
x, v s
y))

{-# INLINE setcdr #-}
-- | Mutate second element of a cons pair.
setcdr
  :: (WithCallStack, MonadEmacs m v)
  => v s -- ^ Cons pair
  -> v s -- ^ New value
  -> m s ()
setcdr :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> v s -> m s ()
setcdr v s
x v s
y = SymbolName -> Tuple2 (v s) -> m s ()
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s ()
funcallPrimitiveSym_ SymbolName
Sym.setcdr ((v s, v s) -> Tuple2 (v s)
forall a. (a, a) -> Tuple2 a
Tuple2 (v s
x, v s
y))

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

{-# INLINE makeList #-}
-- | Construct vanilla Emacs list from a Haskell list.
makeList
  :: (WithCallStack, MonadEmacs m v, Foldable f)
  => f (v s)
  -> m s (v s)
makeList :: forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
f (v s) -> m s (v s)
makeList f (v s)
xs = do
  v s
nilVal <- m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
m s (v s)
nil
  [v s] -> v s -> m s (v s)
forall {k} {m :: k -> * -> *} {s :: k} {v :: k -> *}.
(Monad (m s), MonadEmacs m v) =>
[v s] -> v s -> m s (v s)
mkListLoop ([v s] -> [v s]
forall a. [a] -> [a]
reverse (f (v s) -> [v s]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (v s)
xs)) v s
nilVal
  where
    mkListLoop :: [v s] -> v s -> m s (v s)
mkListLoop [v s]
ys v s
res = case [v s]
ys of
      []     -> v s -> m s (v s)
forall a. a -> m s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v s
res
      v s
z : [v s]
zs -> [v s] -> v s -> m s (v s)
mkListLoop [v s]
zs (v s -> m s (v s)) -> m s (v s) -> m s (v s)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< v s -> v s -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> v s -> m s (v s)
cons v s
z v s
res

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

{-# INLINE extractListWith #-}
-- | Extract vanilla Emacs list as a Haskell list.
extractListWith
  :: (WithCallStack, MonadEmacs m v)
  => (v s -> m s a)
  -> v s
  -> m s [a]
extractListWith :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k) a.
(WithCallStack, MonadEmacs m v) =>
(v s -> m s a) -> v s -> m s [a]
extractListWith v s -> m s a
f = v s -> m s [a]
extractListLoop
  where
    extractListLoop :: v s -> m s [a]
extractListLoop v s
xs = m s [a] -> m s [a]
forall a. m s a -> m s a
forall (m :: * -> *) a. MonadInterleave m => m a -> m a
unsafeInterleave (m s [a] -> m s [a]) -> m s [a] -> m s [a]
forall a b. (a -> b) -> a -> b
$ do
      Bool
nonNil <- v s -> m s Bool
forall (s :: k). WithCallStack => v s -> m s Bool
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Bool
isNotNil v s
xs
      if Bool
nonNil
      then
        (:) (a -> [a] -> [a]) -> m s a -> m s ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (v s -> m s a
f (v s -> m s a) -> m s (v s) -> m s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< v s -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s (v s)
car v s
xs) m s ([a] -> [a]) -> m s [a] -> m s [a]
forall a b. m s (a -> b) -> m s a -> m s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (v s -> m s [a]
extractListLoop (v s -> m s [a]) -> m s (v s) -> m s [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< v s -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s (v s)
cdr v s
xs)
      else
        [a] -> m s [a]
forall a. a -> m s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

{-# INLINE foldlEmacsListWith #-}
-- | Fold Emacs list starting from the left.
foldlEmacsListWith
  :: (WithCallStack, MonadEmacs m v)
  => (a -> v s -> m s a)
  -> a
  -> v s
  -> m s a
foldlEmacsListWith :: forall {k} (m :: k -> * -> *) (v :: k -> *) a (s :: k).
(WithCallStack, MonadEmacs m v) =>
(a -> v s -> m s a) -> a -> v s -> m s a
foldlEmacsListWith a -> v s -> m s a
f = a -> v s -> m s a
go
  where
    go :: a -> v s -> m s a
go a
acc v s
xs = do
      Bool
nonNil <- v s -> m s Bool
forall (s :: k). WithCallStack => v s -> m s Bool
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Bool
isNotNil v s
xs
      if Bool
nonNil
        then do
          a
acc' <- a -> v s -> m s a
f a
acc (v s -> m s a) -> m s (v s) -> m s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< v s -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s (v s)
car v s
xs
          a -> v s -> m s a
go a
acc' (v s -> m s a) -> m s (v s) -> m s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< v s -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s (v s)
cdr v s
xs
        else a -> m s a
forall a. 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 v)
  => (a -> m s (Maybe (v s, a)))
  -> a
  -> m s (v s)
unfoldEmacsListWith :: forall {k} (m :: k -> * -> *) (v :: k -> *) a (s :: k).
(WithCallStack, MonadEmacs m v) =>
(a -> m s (Maybe (v s, a))) -> a -> m s (v s)
unfoldEmacsListWith a -> m s (Maybe (v s, a))
f a
accum = do
  Maybe (v s, a)
accum' <- a -> m s (Maybe (v s, a))
f a
accum
  v s
nilVal <- m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
m s (v s)
nil
  case Maybe (v s, a)
accum' of
    Maybe (v s, a)
Nothing           -> v s -> m s (v s)
forall a. a -> m s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v s
nilVal
    Just (v s
x, a
accum'') -> do
      v s
cell <- v s -> v s -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> v s -> m s (v s)
cons v s
x v s
nilVal
      v s -> a -> v s -> m s ()
go v s
nilVal a
accum'' v s
cell
      v s -> m s (v s)
forall a. a -> m s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v s
cell
  where
    go :: v s -> a -> v s -> m s ()
go v s
nilVal = a -> v s -> m s ()
go'
      where
        go' :: a -> v s -> m s ()
go' a
acc v s
cell = do
          a -> m s (Maybe (v s, a))
f a
acc m s (Maybe (v s, a)) -> (Maybe (v s, a) -> m s ()) -> m s ()
forall a b. m s a -> (a -> m s b) -> m s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (v s, a)
Nothing         -> () -> m s ()
forall a. a -> m s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just (v s
x, a
acc'') -> do
              v s
cell' <- v s -> v s -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> v s -> m s (v s)
cons v s
x v s
nilVal
              v s -> v s -> m s ()
forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> v s -> m s ()
setcdr v s
cell v s
cell'
              a -> v s -> m s ()
go' a
acc'' v s
cell'

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

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

{-# INLINE concat2 #-}
-- | Concatenate two strings.
concat2
  :: (WithCallStack, MonadEmacs m v)
  => v s
  -> v s
  -> m s (v s)
concat2 :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> v s -> m s (v s)
concat2 v s
x v s
y =
  SymbolName -> Tuple2 (v s) -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveSym SymbolName
Sym.concat ((v s, v s) -> Tuple2 (v s)
forall a. (a, a) -> Tuple2 a
Tuple2 (v s
x, v s
y))

{-# INLINE valueToText #-}
-- | Convert an Emacs value into a string using @prin1-to-string@.
valueToText
  :: (WithCallStack, MonadEmacs m v)
  => v s
  -> m s Text
valueToText :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s Text
valueToText =
  v s -> m s Text
forall (s :: k). WithCallStack => v s -> m s Text
forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Text
extractText (v s -> m s Text) -> (v s -> m s (v s)) -> v s -> m s Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SymbolName -> Tuple1 (v s) -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveUncheckedSym SymbolName
Sym.prin1ToString (Tuple1 (v s) -> m s (v s))
-> (v s -> Tuple1 (v s)) -> v s -> m s (v s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v s -> Tuple1 (v s)
forall a. a -> Tuple1 a
Tuple1

{-# INLINE symbolName #-}
-- | Wrapper around Emacs @symbol-name@ function - take a symbol
-- and produce an Emacs string with its textual name.
symbolName
  :: (WithCallStack, MonadEmacs m v)
  => v s
  -> m s (v s)
symbolName :: forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s (v s)
symbolName = SymbolName -> Tuple1 (v s) -> m s (v s)
forall {k} (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(WithCallStack, MonadEmacs m v, Foldable f) =>
SymbolName -> f (v s) -> m s (v s)
funcallPrimitiveSym SymbolName
Sym.symbolName (Tuple1 (v s) -> m s (v s))
-> (v s -> Tuple1 (v s)) -> v s -> m s (v s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v s -> Tuple1 (v s)
forall a. a -> Tuple1 a
Tuple1