----------------------------------------------------------------------------
-- |
-- Module      :  Data.Emacs.Module.SymbolName.Internal
-- Copyright   :  (c) Sergey Vinokurov 2018
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
----------------------------------------------------------------------------

{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE MagicHash        #-}
{-# LANGUAGE TypeFamilies     #-}
{-# LANGUAGE UnliftedNewtypes #-}

{-# OPTIONS_HADDOCK not-home #-}

module Data.Emacs.Module.SymbolName.Internal
  ( Static(..)
  , Dynamic(..)
  , SymbolName(..)
  , mkSymbolName
  , mkSymbolNameString
  , mkSymbolNameShortByteString
  , mkSymbolNameUnsafe

  , mkSymbolNameCache
  , mkCachedSymbolName
  , reifySymbolRaw
  , reifySymbolUnknown
  , reifySymbol
  ) where

import Data.ByteString.Internal qualified as BS
import Data.ByteString.Short qualified as BSS
import Data.Char
import Data.Coerce
import Data.IORef
import Data.String
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error qualified as TE
import Data.Text.Foreign qualified as T
import Foreign.C.Types
import Foreign.Storable
import GHC.Exts (Addr#, unpackCString#)
import GHC.Ptr
import Prettyprinter
import System.IO.Unsafe

import Data.Emacs.Module.NonNullPtr
import Data.Emacs.Module.Raw.Env qualified as Raw
import Data.Emacs.Module.Raw.Env.Internal
import Data.Emacs.Module.Raw.Value
import Emacs.Module.Assert

import Data.Emacs.Module.SymbolName.Predefined.Funcall

-- | Symbols that are known at compile time.
--
-- Will just pass pointer to 0-terminated statically-allocated string
-- to Emacs API when used.
newtype Static = Static { Static -> Ptr CChar
unStatic :: Ptr CChar }
  deriving (Static -> Static -> Bool
(Static -> Static -> Bool)
-> (Static -> Static -> Bool) -> Eq Static
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Static -> Static -> Bool
== :: Static -> Static -> Bool
$c/= :: Static -> Static -> Bool
/= :: Static -> Static -> Bool
Eq, Eq Static
Eq Static =>
(Static -> Static -> Ordering)
-> (Static -> Static -> Bool)
-> (Static -> Static -> Bool)
-> (Static -> Static -> Bool)
-> (Static -> Static -> Bool)
-> (Static -> Static -> Static)
-> (Static -> Static -> Static)
-> Ord Static
Static -> Static -> Bool
Static -> Static -> Ordering
Static -> Static -> Static
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Static -> Static -> Ordering
compare :: Static -> Static -> Ordering
$c< :: Static -> Static -> Bool
< :: Static -> Static -> Bool
$c<= :: Static -> Static -> Bool
<= :: Static -> Static -> Bool
$c> :: Static -> Static -> Bool
> :: Static -> Static -> Bool
$c>= :: Static -> Static -> Bool
>= :: Static -> Static -> Bool
$cmax :: Static -> Static -> Static
max :: Static -> Static -> Static
$cmin :: Static -> Static -> Static
min :: Static -> Static -> Static
Ord, Int -> Static -> ShowS
[Static] -> ShowS
Static -> String
(Int -> Static -> ShowS)
-> (Static -> String) -> ([Static] -> ShowS) -> Show Static
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Static -> ShowS
showsPrec :: Int -> Static -> ShowS
$cshow :: Static -> String
show :: Static -> String
$cshowList :: [Static] -> ShowS
showList :: [Static] -> ShowS
Show)

newtype Dynamic = Dynamic { Dynamic -> Text
unDynamic :: Text }
  deriving (Dynamic -> Dynamic -> Bool
(Dynamic -> Dynamic -> Bool)
-> (Dynamic -> Dynamic -> Bool) -> Eq Dynamic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Dynamic -> Dynamic -> Bool
== :: Dynamic -> Dynamic -> Bool
$c/= :: Dynamic -> Dynamic -> Bool
/= :: Dynamic -> Dynamic -> Bool
Eq, Eq Dynamic
Eq Dynamic =>
(Dynamic -> Dynamic -> Ordering)
-> (Dynamic -> Dynamic -> Bool)
-> (Dynamic -> Dynamic -> Bool)
-> (Dynamic -> Dynamic -> Bool)
-> (Dynamic -> Dynamic -> Bool)
-> (Dynamic -> Dynamic -> Dynamic)
-> (Dynamic -> Dynamic -> Dynamic)
-> Ord Dynamic
Dynamic -> Dynamic -> Bool
Dynamic -> Dynamic -> Ordering
Dynamic -> Dynamic -> Dynamic
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Dynamic -> Dynamic -> Ordering
compare :: Dynamic -> Dynamic -> Ordering
$c< :: Dynamic -> Dynamic -> Bool
< :: Dynamic -> Dynamic -> Bool
$c<= :: Dynamic -> Dynamic -> Bool
<= :: Dynamic -> Dynamic -> Bool
$c> :: Dynamic -> Dynamic -> Bool
> :: Dynamic -> Dynamic -> Bool
$c>= :: Dynamic -> Dynamic -> Bool
>= :: Dynamic -> Dynamic -> Bool
$cmax :: Dynamic -> Dynamic -> Dynamic
max :: Dynamic -> Dynamic -> Dynamic
$cmin :: Dynamic -> Dynamic -> Dynamic
min :: Dynamic -> Dynamic -> Dynamic
Ord, Int -> Dynamic -> ShowS
[Dynamic] -> ShowS
Dynamic -> String
(Int -> Dynamic -> ShowS)
-> (Dynamic -> String) -> ([Dynamic] -> ShowS) -> Show Dynamic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dynamic -> ShowS
showsPrec :: Int -> Dynamic -> ShowS
$cshow :: Dynamic -> String
show :: Dynamic -> String
$cshowList :: [Dynamic] -> ShowS
showList :: [Dynamic] -> ShowS
Show, (forall ann. Dynamic -> Doc ann)
-> (forall ann. [Dynamic] -> Doc ann) -> Pretty Dynamic
forall ann. [Dynamic] -> Doc ann
forall ann. Dynamic -> Doc ann
forall a.
(forall ann. a -> Doc ann)
-> (forall ann. [a] -> Doc ann) -> Pretty a
$cpretty :: forall ann. Dynamic -> Doc ann
pretty :: forall ann. Dynamic -> Doc ann
$cprettyList :: forall ann. [Dynamic] -> Doc ann
prettyList :: forall ann. [Dynamic] -> Doc ann
Pretty)

data SymbolName
  = StaticSymbol  {-# UNPACK #-} !(Ptr CChar)
  | DynamicSymbol {-# UNPACK #-} !Text
  | CachedSymbol  (IORef (Env -> IO (RawValue 'Pinned))) SymbolName
  deriving (SymbolName -> SymbolName -> Bool
(SymbolName -> SymbolName -> Bool)
-> (SymbolName -> SymbolName -> Bool) -> Eq SymbolName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SymbolName -> SymbolName -> Bool
== :: SymbolName -> SymbolName -> Bool
$c/= :: SymbolName -> SymbolName -> Bool
/= :: SymbolName -> SymbolName -> Bool
Eq)

instance Show SymbolName where
  show :: SymbolName -> String
show = \case
    StaticSymbol (Ptr Addr#
addr)
      -> Text -> String
forall a. Show a => a -> String
show (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Addr# -> ByteString
BS.unsafePackLiteral Addr#
addr
    DynamicSymbol Text
str  -> Text -> String
forall a. Show a => a -> String
show Text
str
    CachedSymbol IORef (Env -> IO (RawValue 'Pinned))
_ SymbolName
sym -> SymbolName -> String
forall a. Show a => a -> String
show SymbolName
sym

instance Pretty SymbolName where
  pretty :: forall ann. SymbolName -> Doc ann
pretty = \case
    StaticSymbol (Ptr Addr#
addr)
      -> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Addr# -> ByteString
BS.unsafePackLiteral Addr#
addr
    DynamicSymbol Text
str  -> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
str
    CachedSymbol IORef (Env -> IO (RawValue 'Pinned))
_ SymbolName
sym -> SymbolName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. SymbolName -> Doc ann
pretty SymbolName
sym

mkSymbolNameCache :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))
mkSymbolNameCache :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))
mkSymbolNameCache = SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))
go
  where
    go :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))
    go :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))
go !SymbolName
name =
      (IORef (Env -> IO (RawValue 'Pinned))
 -> IO (IORef (Env -> IO (RawValue 'Pinned))))
-> IO (IORef (Env -> IO (RawValue 'Pinned)))
forall a. (a -> IO a) -> IO a
unsafeFixIO ((IORef (Env -> IO (RawValue 'Pinned))
  -> IO (IORef (Env -> IO (RawValue 'Pinned))))
 -> IO (IORef (Env -> IO (RawValue 'Pinned))))
-> (IORef (Env -> IO (RawValue 'Pinned))
    -> IO (IORef (Env -> IO (RawValue 'Pinned))))
-> IO (IORef (Env -> IO (RawValue 'Pinned)))
forall a b. (a -> b) -> a -> b
$ \ IORef (Env -> IO (RawValue 'Pinned))
ref ->
        (Env -> IO (RawValue 'Pinned))
-> IO (IORef (Env -> IO (RawValue 'Pinned)))
forall a. a -> IO (IORef a)
newIORef ((Env -> IO (RawValue 'Pinned))
 -> IO (IORef (Env -> IO (RawValue 'Pinned))))
-> (Env -> IO (RawValue 'Pinned))
-> IO (IORef (Env -> IO (RawValue 'Pinned)))
forall a b. (a -> b) -> a -> b
$ \Env
env -> do
          !RawValue 'Pinned
global <- Env -> RawValue 'Regular -> IO (RawValue 'Pinned)
forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m (RawValue 'Pinned)
Raw.makeGlobalRef Env
env (RawValue 'Regular -> IO (RawValue 'Pinned))
-> IO (RawValue 'Regular) -> IO (RawValue 'Pinned)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> SymbolName -> IO (RawValue 'Regular)
reifySymbolRaw Env
env SymbolName
name
          IORef (Env -> IO (RawValue 'Pinned))
-> (Env -> IO (RawValue 'Pinned)) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Env -> IO (RawValue 'Pinned))
ref ((Env -> IO (RawValue 'Pinned)) -> IO ())
-> (Env -> IO (RawValue 'Pinned)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Env
_env -> RawValue 'Pinned -> IO (RawValue 'Pinned)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawValue 'Pinned
global
          RawValue 'Pinned -> IO (RawValue 'Pinned)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawValue 'Pinned
global

{-# INLINE mkCachedSymbolName #-}
mkCachedSymbolName :: IORef (Env -> IO (RawValue 'Pinned)) -> SymbolName -> SymbolName
mkCachedSymbolName :: IORef (Env -> IO (RawValue 'Pinned)) -> SymbolName -> SymbolName
mkCachedSymbolName = IORef (Env -> IO (RawValue 'Pinned)) -> SymbolName -> SymbolName
CachedSymbol

-- | Should be applied to unboxed string literals like this
--
-- @
-- mkSymbolNameUnsafe "foo"#
-- @
--
-- Can be safely applied to non-literals (e.g. arbitrary pointers) if
-- it's guaranteed that address points to a null-terminated strings.
-- Otherwise behaviour is undefined.
--
-- The string literal must only contain ASCII symbols. This condition
-- is required by the Emacs API and results in undefined behaviour if
-- violated.
{-# INLINE mkSymbolNameUnsafe #-}
mkSymbolNameUnsafe :: Addr# -> SymbolName
mkSymbolNameUnsafe :: Addr# -> SymbolName
mkSymbolNameUnsafe Addr#
addr = Ptr CChar -> SymbolName
StaticSymbol (Addr# -> Ptr CChar
forall a. Addr# -> Ptr a
Ptr Addr#
addr)

{-# INLINE mkSymbolName #-}
mkSymbolName :: Text -> SymbolName
mkSymbolName :: Text -> SymbolName
mkSymbolName = Text -> SymbolName
DynamicSymbol

{-# INLINE mkSymbolNameShortByteString #-}
mkSymbolNameShortByteString :: BSS.ShortByteString -> SymbolName
mkSymbolNameShortByteString :: ShortByteString -> SymbolName
mkSymbolNameShortByteString = Text -> SymbolName
DynamicSymbol (Text -> SymbolName)
-> (ShortByteString -> Text) -> ShortByteString -> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode (ByteString -> Text)
-> (ShortByteString -> ByteString) -> ShortByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
BSS.fromShort

{-# INLINE [0] mkSymbolNameString #-}
mkSymbolNameString :: String -> SymbolName
mkSymbolNameString :: String -> SymbolName
mkSymbolNameString = Text -> SymbolName
mkSymbolName (Text -> SymbolName) -> (String -> Text) -> String -> SymbolName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance IsString SymbolName where
  {-# INLINE fromString #-}
  fromString :: String -> SymbolName
fromString = String -> SymbolName
mkSymbolNameString

{-# RULES
"SymbolName string literal" forall s .
   mkSymbolNameString (unpackCString# s) = mkSymbolNameUnsafe s
 #-}

{-# INLINE reifySymbolRaw #-}
reifySymbolRaw :: Env -> SymbolName -> IO (RawValue 'Regular)
reifySymbolRaw :: Env -> SymbolName -> IO (RawValue 'Regular)
reifySymbolRaw Env
env SymbolName
sym = Env
-> SymbolName
-> (RawValue 'Regular -> RawValue 'Regular)
-> (RawValue 'Pinned -> RawValue 'Regular)
-> IO (RawValue 'Regular)
forall a.
(() :: Constraint) =>
Env
-> SymbolName
-> (RawValue 'Regular -> a)
-> (RawValue 'Pinned -> a)
-> IO a
reifySymbol Env
env SymbolName
sym RawValue 'Regular -> RawValue 'Regular
forall a. a -> a
id RawValue 'Pinned -> RawValue 'Regular
forall a b. Coercible a b => a -> b
coerce

{-# INLINE reifySymbolUnknown #-}
reifySymbolUnknown :: Env -> SymbolName -> IO (RawValue 'Unknown)
reifySymbolUnknown :: Env -> SymbolName -> IO (RawValue 'Unknown)
reifySymbolUnknown Env
env SymbolName
sym = Env
-> SymbolName
-> (RawValue 'Regular -> RawValue 'Unknown)
-> (RawValue 'Pinned -> RawValue 'Unknown)
-> IO (RawValue 'Unknown)
forall a.
(() :: Constraint) =>
Env
-> SymbolName
-> (RawValue 'Regular -> a)
-> (RawValue 'Pinned -> a)
-> IO a
reifySymbol Env
env SymbolName
sym RawValue 'Regular -> RawValue 'Unknown
forall a b. Coercible a b => a -> b
coerce RawValue 'Pinned -> RawValue 'Unknown
forall a b. Coercible a b => a -> b
coerce

{-# INLINE reifySymbol #-}
reifySymbol
  :: WithCallStack
  => Env -> SymbolName -> (RawValue 'Regular -> a) -> (RawValue 'Pinned -> a) -> IO a
reifySymbol :: forall a.
(() :: Constraint) =>
Env
-> SymbolName
-> (RawValue 'Regular -> a)
-> (RawValue 'Pinned -> a)
-> IO a
reifySymbol Env
env SymbolName
sym RawValue 'Regular -> a
f RawValue 'Pinned -> a
g = case SymbolName
sym of
  StaticSymbol Ptr CChar
addr ->
    RawValue 'Regular -> a
f (RawValue 'Regular -> a) -> IO (RawValue 'Regular) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Ptr CChar -> IO (RawValue 'Regular)
forall (m :: * -> *).
MonadIO m =>
Env -> Ptr CChar -> m (RawValue 'Regular)
Raw.intern Env
env Ptr CChar
addr
  DynamicSymbol Text
str
    -- If it's only ASCII then can run FFI intern, otherwise have to go via funcall
    -- TODO: cache this check
    | (Char -> Bool) -> Text -> Bool
T.all (\Char
c -> Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
128) Text
str ->
      RawValue 'Regular -> a
f (RawValue 'Regular -> a) -> IO (RawValue 'Regular) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> (Ptr CChar -> IO (RawValue 'Regular)) -> IO (RawValue 'Regular)
forall a. Text -> (Ptr CChar -> IO a) -> IO a
T.withCString Text
str (Env -> Ptr CChar -> IO (RawValue 'Regular)
forall (m :: * -> *).
MonadIO m =>
Env -> Ptr CChar -> m (RawValue 'Regular)
Raw.intern Env
env)
    | Bool
otherwise                    ->
      Text -> (CStringLen -> IO a) -> IO a
forall a. Text -> (CStringLen -> IO a) -> IO a
T.withCStringLen Text
str ((CStringLen -> IO a) -> IO a) -> (CStringLen -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr, Int
len) -> do
        RawValue 'Regular
str' <- Bool -> String -> IO (RawValue 'Regular) -> IO (RawValue 'Regular)
forall a. Bool -> String -> a -> a
emacsAssert (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) String
"Symbol text length must be non-negative" (IO (RawValue 'Regular) -> IO (RawValue 'Regular))
-> IO (RawValue 'Regular) -> IO (RawValue 'Regular)
forall a b. (a -> b) -> a -> b
$
          Env -> Ptr CChar -> CPtrdiff -> IO (RawValue 'Regular)
forall (m :: * -> *).
MonadIO m =>
Env -> Ptr CChar -> CPtrdiff -> m (RawValue 'Regular)
Raw.makeString Env
env Ptr CChar
ptr (Int -> CPtrdiff
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        RawValue 'Unknown
funcall' <- Env -> SymbolName -> IO (RawValue 'Unknown)
reifySymbolUnknown Env
env SymbolName
funcall
        (NonNullPtr (RawValue 'Regular) -> IO a) -> IO a
forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull ((NonNullPtr (RawValue 'Regular) -> IO a) -> IO a)
-> (NonNullPtr (RawValue 'Regular) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \NonNullPtr (RawValue 'Regular)
args -> do
          Ptr (RawValue 'Regular) -> RawValue 'Regular -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (NonNullPtr (RawValue 'Regular) -> Ptr (RawValue 'Regular)
forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr (RawValue 'Regular)
args) RawValue 'Regular
str'
          RawValue 'Regular -> a
f (RawValue 'Regular -> a) -> IO (RawValue 'Regular) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
-> RawValue 'Unknown
-> CPtrdiff
-> NonNullPtr (RawValue 'Regular)
-> IO (RawValue 'Regular)
forall (m :: * -> *) (p1 :: Pinning) (p2 :: Pinning).
MonadIO m =>
Env
-> RawValue p1
-> CPtrdiff
-> NonNullPtr (RawValue p2)
-> m (RawValue 'Regular)
Raw.funcallPrimitive Env
env RawValue 'Unknown
funcall' CPtrdiff
1 NonNullPtr (RawValue 'Regular)
args

  CachedSymbol IORef (Env -> IO (RawValue 'Pinned))
ref SymbolName
_ ->
    RawValue 'Pinned -> a
g (RawValue 'Pinned -> a) -> IO (RawValue 'Pinned) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((\Env -> IO (RawValue 'Pinned)
k -> Env -> IO (RawValue 'Pinned)
k Env
env) ((Env -> IO (RawValue 'Pinned)) -> IO (RawValue 'Pinned))
-> IO (Env -> IO (RawValue 'Pinned)) -> IO (RawValue 'Pinned)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Env -> IO (RawValue 'Pinned))
-> IO (Env -> IO (RawValue 'Pinned))
forall a. IORef a -> IO a
readIORef IORef (Env -> IO (RawValue 'Pinned))
ref)