{-# LANGUAGE CPP, MagicHash #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Module      : Data.Text.Show
-- Copyright   : (c) 2009-2015 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC

module Data.Text.Show
    (
      addrLen
    , singleton
    , unpack
    , unpackCString#
    , unpackCStringAscii#
    ) where

import Control.Monad.ST (ST, runST)
import Data.Text.Internal (Text(..), empty_, safe, pack)
import Data.Text.Internal.Encoding.Utf8 (utf8Length)
import Data.Text.Internal.Fusion (stream)
import Data.Text.Internal.Unsafe.Char (unsafeWrite)
import GHC.Exts (Ptr(..), Int(..), Addr#, indexWord8OffAddr#)
import GHC.Word (Word8(..))
import qualified Data.Text.Array as A
import qualified Data.Text.Internal.Fusion.Common as S
#if !MIN_VERSION_ghc_prim(0,7,0)
import Foreign.C.String (CString)
import Foreign.C.Types (CSize(..))
#endif

import qualified GHC.CString as GHC

#if defined(ASSERTS)
import GHC.Stack (HasCallStack)
#endif

instance Show Text where
    showsPrec :: Int -> Text -> ShowS
showsPrec Int
p Text
ps String
r = Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (Text -> String
unpack Text
ps) String
r

-- | /O(n)/ Convert a 'Text' into a 'String'.
unpack ::
#if defined(ASSERTS)
  HasCallStack =>
#endif
  Text -> String
unpack :: Text -> String
unpack = Stream Char -> String
forall a. Stream a -> [a]
S.unstreamList (Stream Char -> String) -> (Text -> Stream Char) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Stream Char
stream
{-# INLINE [1] unpack #-}

-- | /O(n)/ Convert a null-terminated
-- <https://en.wikipedia.org/wiki/UTF-8#Modified_UTF-8 modified UTF-8>
-- (but with a standard UTF-8 representation of characters from supplementary planes)
-- string to a 'Text'. Counterpart to 'GHC.unpackCStringUtf8#'.
-- No validation is performed, malformed input can lead to memory access violation.
--
-- @since 1.2.1.1
unpackCString# :: Addr# -> Text
unpackCString# :: Addr# -> Text
unpackCString# Addr#
addr# = (forall s. ST s Text) -> Text
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s Text) -> Text) -> (forall s. ST s Text) -> Text
forall a b. (a -> b) -> a -> b
$ do
  let l :: Int
l = Addr# -> Int
addrLen Addr#
addr#
      at :: Int -> Word8
at (I# Int#
i#) = Word8# -> Word8
W8# (Addr# -> Int# -> Word8#
indexWord8OffAddr# Addr#
addr# Int#
i#)
  MArray s
marr <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
l
  let go :: Int -> Int -> ST s Int
go srcOff :: Int
srcOff@(Int -> Word8
at -> Word8
w8) Int
dstOff
        | Int
srcOff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
l
        = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
dstOff
        -- Surrogate halves take 3 bytes and are replaced by \xfffd (also 3 bytes long).
        -- Cf. Data.Text.Internal.safe
        | Word8
w8 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xed, Int -> Word8
at (Int
srcOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0xa0 = do
          MArray s -> Int -> Word8 -> ST s ()
forall s. MArray s -> Int -> Word8 -> ST s ()
A.unsafeWrite MArray s
marr  Int
dstOff      Word8
0xef
          MArray s -> Int -> Word8 -> ST s ()
forall s. MArray s -> Int -> Word8 -> ST s ()
A.unsafeWrite MArray s
marr (Int
dstOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8
0xbf
          MArray s -> Int -> Word8 -> ST s ()
forall s. MArray s -> Int -> Word8 -> ST s ()
A.unsafeWrite MArray s
marr (Int
dstOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Word8
0xbd
          Int -> Int -> ST s Int
go (Int
srcOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Int
dstOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
        -- Byte sequence "\xc0\x80" is used to represent NUL
        | Word8
w8 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xc0, Int -> Word8
at (Int
srcOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80
        = MArray s -> Int -> Word8 -> ST s ()
forall s. MArray s -> Int -> Word8 -> ST s ()
A.unsafeWrite MArray s
marr Int
dstOff Word8
0  ST s () -> ST s Int -> ST s Int
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> ST s Int
go (Int
srcOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Int
dstOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        | Bool
otherwise
        = MArray s -> Int -> Word8 -> ST s ()
forall s. MArray s -> Int -> Word8 -> ST s ()
A.unsafeWrite MArray s
marr Int
dstOff Word8
w8 ST s () -> ST s Int -> ST s Int
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> ST s Int
go (Int
srcOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
dstOff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Int
actualLen <- Int -> Int -> ST s Int
go Int
0 Int
0
  MArray s -> Int -> ST s ()
forall s. MArray s -> Int -> ST s ()
A.shrinkM MArray s
marr Int
actualLen
  Array
arr <- MArray s -> ST s Array
forall s. MArray s -> ST s Array
A.unsafeFreeze MArray s
marr
  Text -> ST s Text
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ST s Text) -> Text -> ST s Text
forall a b. (a -> b) -> a -> b
$ Array -> Int -> Int -> Text
Text Array
arr Int
0 Int
actualLen

-- When a module contains many literal strings, 'unpackCString#' can easily
-- bloat generated code to insane size. There is also very little to gain
-- from inlining. Thus explicit NOINLINE is desired.
{-# NOINLINE unpackCString# #-}

-- | /O(n)/ Convert a null-terminated ASCII string to a 'Text'.
-- Counterpart to 'GHC.unpackCString#'.
-- No validation is performed, malformed input can lead to memory access violation.
--
-- @since 2.0
unpackCStringAscii# :: Addr# -> Text
unpackCStringAscii# :: Addr# -> Text
unpackCStringAscii# Addr#
addr# = Array -> Int -> Int -> Text
Text Array
ba Int
0 Int
l
  where
    l :: Int
l = Addr# -> Int
addrLen Addr#
addr#
    ba :: Array
ba = (forall s. ST s Array) -> Array
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s Array) -> Array)
-> (forall s. ST s Array) -> Array
forall a b. (a -> b) -> a -> b
$ do
      MArray s
marr <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
l
      MArray s -> Int -> Ptr Word8 -> Int -> ST s ()
forall s. MArray s -> Int -> Ptr Word8 -> Int -> ST s ()
A.copyFromPointer MArray s
marr Int
0 (Addr# -> Ptr Word8
forall a. Addr# -> Ptr a
Ptr Addr#
addr#) Int
l
      MArray s -> ST s Array
forall s. MArray s -> ST s Array
A.unsafeFreeze MArray s
marr
{-# NOINLINE unpackCStringAscii# #-}

addrLen :: Addr# -> Int
#if MIN_VERSION_ghc_prim(0,7,0)
addrLen :: Addr# -> Int
addrLen Addr#
addr# = Int# -> Int
I# (Addr# -> Int#
GHC.cstringLength# Addr#
addr#)
#else
addrLen addr# = fromIntegral (c_strlen (Ptr addr#))

foreign import capi unsafe "string.h strlen" c_strlen :: CString -> CSize
#endif

{-# RULES "TEXT literal" forall a.
    pack (GHC.unpackCString# a) = unpackCStringAscii# a #-}

{-# RULES "TEXT literal UTF8" forall a.
    pack (GHC.unpackCStringUtf8# a) = unpackCString# a #-}

{-# RULES "TEXT empty literal"
    pack [] = empty_ #-}

{-# RULES "TEXT singleton literal" forall a.
    pack [a] = singleton a #-}

-- | /O(1)/ Convert a character into a Text.
-- Performs replacement on invalid scalar values.
singleton ::
#if defined(ASSERTS)
  HasCallStack =>
#endif
  Char -> Text
singleton :: Char -> Text
singleton Char
c = Array -> Int -> Int -> Text
Text ((forall s. ST s (MArray s)) -> Array
A.run ST s (MArray s)
forall s. ST s (MArray s)
x) Int
0 Int
len
  where x :: ST s (A.MArray s)
        x :: forall s. ST s (MArray s)
x = do MArray s
arr <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
len
               Int
_ <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
arr Int
0 Char
d
               MArray s -> ST s (MArray s)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MArray s
arr
        len :: Int
len = Char -> Int
utf8Length Char
d
        d :: Char
d = Char -> Char
safe Char
c
{-# NOINLINE singleton #-}