----------------------------------------------------------------------------
-- |
-- 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' <- forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
SymbolName -> m s (v s)
intern SymbolName
func
  forall k (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(MonadEmacs m v, 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' <- forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
SymbolName -> m s (v s)
intern SymbolName
func
  forall k (m :: k -> * -> *) (v :: k -> *) (f :: * -> *) (s :: k).
(MonadEmacs m v, 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 =
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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' <- forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
SymbolName -> m s (v s)
intern SymbolName
name
  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' <- forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
SymbolName -> m s (v s)
intern SymbolName
sym
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 =
  forall k (m :: k -> * -> *) (v :: k -> *) a (s :: k).
(MonadEmacs m v, WithCallStack) =>
FinalizerPtr a -> Ptr a -> m s (v s)
makeUserPtr forall a. FinalizerPtr a
Env.freeStablePtrFinaliser forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Ptr () -> StablePtr a
castPtrToStablePtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Int64
extractWideInteger v s
x
  forall a. Bool -> String -> a -> a
emacsAssert
    (Int64
y forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int))
    (String
"Integer is too wide to fit into Int: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
y)
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> PlatformString
PosixString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
Int64 -> m s (v s)
makeWideInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
ByteString -> m s (v s)
makeString 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 = forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
ByteString -> m s (v s)
makeString 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 = 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 forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
SymbolName -> m s (v s)
intern SymbolName
Sym.t else 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 <- forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Int
vecSize v s
xs
  forall (m :: * -> *) (v :: * -> *) a.
(Monad m, Vector v a) =>
Int -> (Int -> m a) -> m (v a)
G.generateM Int
n forall a b. (a -> b) -> a -> b
$ v s -> m s a
f forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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 <- forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Int
vecSize v s
xs
  forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
Int -> (Int -> m a) -> m (v (PrimState m) a)
GM.generateM Int
n forall a b. (a -> b) -> a -> b
$ v s -> m s a
f forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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 <- forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Int
vecSize v s
xs
  forall (f :: * -> *) a.
(Applicative f, Prim a) =>
Int -> (Int -> f a) -> f (PrimArray a)
generatePrimArrayA Int
n forall a b. (a -> b) -> a -> b
$ v s -> m s a
f forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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 = 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 =
  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 (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 = 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 (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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = 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 (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 = 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 (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 <- forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
m s (v s)
nil
  forall {k} {m :: k -> * -> *} {s :: k} {v :: k -> *}.
(Monad (m s), MonadEmacs m v) =>
[v s] -> v s -> m s (v s)
mkListLoop (forall a. [a] -> [a]
reverse (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
      []     -> 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k) a.
(WithCallStack, MonadEmacs m v) =>
(v s -> m s a) -> v s -> m s [a]
extractListWith 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 = forall (m :: * -> *) a. MonadInterleave m => m a -> m a
unsafeInterleave forall a b. (a -> b) -> a -> b
$ do
      Bool
nonNil <- 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
        (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (v s -> m s a
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s (v s)
car v s
xs) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (v s -> m s [a]
extractListLoop forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s (v s)
cdr v s
xs)
      else
        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 <- 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {k} (m :: k -> * -> *) (v :: k -> *) (s :: k).
(WithCallStack, MonadEmacs m v) =>
v s -> m s (v s)
cdr v s
xs
        else 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 <- 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           -> forall (f :: * -> *) a. Applicative f => a -> f a
pure v s
nilVal
    Just (v s
x, a
accum'') -> do
      v s
cell <- 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
      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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (v s, a)
Nothing         -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just (v s
x, a
acc'') -> do
              v s
cell' <- 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
              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' <- forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
SymbolName -> m s (v s)
intern SymbolName
face
  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' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(SymbolName
name, v s
val) -> (\v s
name' -> [v s
name', v s
val]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
SymbolName -> m s (v s)
intern SymbolName
name) [(SymbolName, v s)]
props
  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 forall a. a -> [a] -> [a]
: 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 =
  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 (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 =
  forall k (m :: k -> * -> *) (v :: k -> *) (s :: k).
(MonadEmacs m v, WithCallStack) =>
v s -> m s Text
extractText forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Tuple1 a
Tuple1