content: ----------------------------------------------------------------------------
  -- |
  -- 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 { unStatic :: Ptr CChar }
    deriving (Eq, Ord, Show)
  
  newtype Dynamic = Dynamic { unDynamic :: Text }
    deriving (Eq, Ord, Show, Pretty)
  
  data SymbolName
    = StaticSymbol  {-# UNPACK #-} !(Ptr CChar)
    | DynamicSymbol {-# UNPACK #-} !Text
    | CachedSymbol  (IORef (Env -> IO (RawValue 'Pinned))) SymbolName
    deriving (Eq)
  
  instance Show SymbolName where
    show = \case
      StaticSymbol (Ptr addr)
        -> show $ TE.decodeUtf8With TE.lenientDecode $ BS.unsafePackLiteral addr
      DynamicSymbol str  -> show str
      CachedSymbol _ sym -> show sym
  
  instance Pretty SymbolName where
    pretty = \case
      StaticSymbol (Ptr addr)
        -> pretty $ TE.decodeUtf8With TE.lenientDecode $ BS.unsafePackLiteral addr
      DynamicSymbol str  -> pretty str
      CachedSymbol _ sym -> pretty sym
  
  mkSymbolNameCache :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))
  mkSymbolNameCache = go
    where
      go :: SymbolName -> IO (IORef (Env -> IO (RawValue 'Pinned)))
      go !name =
        unsafeFixIO $ \ ref ->
          newIORef $ \env -> do
            !global <- Raw.makeGlobalRef env =<< reifySymbolRaw env name
            writeIORef ref $ \_env -> pure global
            pure global
  
  {-# INLINE mkCachedSymbolName #-}
  mkCachedSymbolName :: IORef (Env -> IO (RawValue 'Pinned)) -> SymbolName -> SymbolName
  mkCachedSymbolName = 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 = StaticSymbol (Ptr addr)
  
  {-# INLINE mkSymbolName #-}
  mkSymbolName :: Text -> SymbolName
  mkSymbolName = DynamicSymbol
  
  {-# INLINE mkSymbolNameShortByteString #-}
  mkSymbolNameShortByteString :: BSS.ShortByteString -> SymbolName
  mkSymbolNameShortByteString = DynamicSymbol . TE.decodeUtf8With TE.lenientDecode . BSS.fromShort
  
  {-# INLINE [0] mkSymbolNameString #-}
  mkSymbolNameString :: String -> SymbolName
  mkSymbolNameString = mkSymbolName . T.pack
  
  instance IsString SymbolName where
    {-# INLINE fromString #-}
    fromString = mkSymbolNameString
  
  {-# RULES
  "SymbolName string literal" forall s .
     mkSymbolNameString (unpackCString# s) = mkSymbolNameUnsafe s
   #-}
  
  {-# INLINE reifySymbolRaw #-}
  reifySymbolRaw :: Env -> SymbolName -> IO (RawValue 'Regular)
  reifySymbolRaw env sym = reifySymbol env sym id coerce
  
  {-# INLINE reifySymbolUnknown #-}
  reifySymbolUnknown :: Env -> SymbolName -> IO (RawValue 'Unknown)
  reifySymbolUnknown env sym = reifySymbol env sym coerce coerce
  
  {-# INLINE reifySymbol #-}
  reifySymbol
    :: WithCallStack
    => Env -> SymbolName -> (RawValue 'Regular -> a) -> (RawValue 'Pinned -> a) -> IO a
  reifySymbol env sym f g = case sym of
    StaticSymbol addr ->
      f <$> Raw.intern env addr
    DynamicSymbol str
      -- If it's only ASCII then can run FFI intern, otherwise have to go via funcall
      -- TODO: cache this check
      | T.all (\c -> ord c < 128) str ->
        f <$> T.withCString str (Raw.intern env)
      | otherwise                    ->
        T.withCStringLen str $ \(ptr, len) -> do
          str' <- emacsAssert (len >= 0) "Symbol text length must be non-negative" $
            Raw.makeString env ptr (fromIntegral len)
          funcall' <- reifySymbolUnknown env funcall
          allocaNonNull $ \args -> do
            poke (unNonNullPtr args) str'
            f <$> Raw.funcallPrimitive env funcall' 1 args
  
    CachedSymbol ref _ ->
      g <$> ((\k -> k env) =<< readIORef ref)
  