----------------------------------------------------------------------------
-- |
-- 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Static -> Static -> Bool
$c/= :: Static -> Static -> Bool
== :: Static -> Static -> Bool
$c== :: Static -> Static -> Bool
Eq, Eq 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
min :: Static -> Static -> Static
$cmin :: Static -> Static -> Static
max :: Static -> Static -> Static
$cmax :: Static -> Static -> Static
>= :: Static -> Static -> Bool
$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
compare :: Static -> Static -> Ordering
$ccompare :: Static -> Static -> Ordering
Ord, Int -> Static -> ShowS
[Static] -> ShowS
Static -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Static] -> ShowS
$cshowList :: [Static] -> ShowS
show :: Static -> String
$cshow :: Static -> String
showsPrec :: Int -> Static -> ShowS
$cshowsPrec :: Int -> Static -> ShowS
Show)

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

instance Show SymbolName where
  show :: SymbolName -> String
show = \case
    StaticSymbol (Ptr Addr#
addr)
      -> forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode forall a b. (a -> b) -> a -> b
$ Addr# -> ByteString
BS.unsafePackLiteral Addr#
addr
    DynamicSymbol Text
str  -> forall a. Show a => a -> String
show Text
str
    CachedSymbol IORef (Env -> IO (RawValue 'Pinned))
_ SymbolName
sym -> 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)
      -> forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode forall a b. (a -> b) -> a -> b
$ Addr# -> ByteString
BS.unsafePackLiteral Addr#
addr
    DynamicSymbol Text
str  -> forall a ann. Pretty a => a -> Doc ann
pretty Text
str
    CachedSymbol IORef (Env -> IO (RawValue 'Pinned))
_ SymbolName
sym -> forall a ann. Pretty a => a -> 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 =
      forall a. (a -> IO a) -> IO a
unsafeFixIO forall a b. (a -> b) -> a -> b
$ \ IORef (Env -> IO (RawValue 'Pinned))
ref ->
        forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ \Env
env -> do
          !RawValue 'Pinned
global <- forall (m :: * -> *) (p :: Pinning).
MonadIO m =>
Env -> RawValue p -> m (RawValue 'Pinned)
Raw.makeGlobalRef Env
env forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> SymbolName -> IO (RawValue 'Regular)
reifySymbolRaw Env
env SymbolName
name
          forall a. IORef a -> a -> IO ()
writeIORef IORef (Env -> IO (RawValue 'Pinned))
ref forall a b. (a -> b) -> a -> b
$ \Env
_env -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RawValue 'Pinned
global
          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 (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TE.lenientDecode 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 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 = forall a.
WithCallStack =>
Env
-> SymbolName
-> (RawValue 'Regular -> a)
-> (RawValue 'Pinned -> a)
-> IO a
reifySymbol Env
env SymbolName
sym forall a. a -> a
id coerce :: 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 = forall a.
WithCallStack =>
Env
-> SymbolName
-> (RawValue 'Regular -> a)
-> (RawValue 'Pinned -> a)
-> IO a
reifySymbol Env
env SymbolName
sym coerce :: forall a b. Coercible a b => a -> b
coerce coerce :: 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.
WithCallStack =>
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a. Ord a => a -> a -> Bool
< Int
128) Text
str ->
      RawValue 'Regular -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> (Ptr CChar -> IO a) -> IO a
T.withCString Text
str (forall (m :: * -> *).
MonadIO m =>
Env -> Ptr CChar -> m (RawValue 'Regular)
Raw.intern Env
env)
    | Bool
otherwise                    ->
      forall a. Text -> (CStringLen -> IO a) -> IO a
T.withCStringLen Text
str forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr, Int
len) -> do
        RawValue 'Regular
str' <- forall a. Bool -> String -> a -> a
emacsAssert (Int
len forall a. Ord a => a -> a -> Bool
>= Int
0) String
"Symbol text length must be non-negative" forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *).
MonadIO m =>
Env -> Ptr CChar -> CPtrdiff -> m (RawValue 'Regular)
Raw.makeString Env
env Ptr CChar
ptr (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
        forall a b. Storable a => (NonNullPtr a -> IO b) -> IO b
allocaNonNull forall a b. (a -> b) -> a -> b
$ \NonNullPtr (RawValue 'Regular)
args -> do
          forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a. NonNullPtr a -> Ptr a
unNonNullPtr NonNullPtr (RawValue 'Regular)
args) RawValue 'Regular
str'
          RawValue 'Regular -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((\Env -> IO (RawValue 'Pinned)
k -> Env -> IO (RawValue 'Pinned)
k Env
env) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IORef a -> IO a
readIORef IORef (Env -> IO (RawValue 'Pinned))
ref)