{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

{-# OPTIONS_GHC -Wall -funbox-strict-fields #-}

{-| For concatenating fixed-width strings that are only a few
    characters each, this can be ten times faster than the builder
    that ships with @text@.
-}
module Data.Text.Builder.Fixed
  ( Builder
  , fromText
  , run
  , contramapBuilder
  , charBmp
  , word8HexFixedLower
  , word8HexFixedUpper
  , word12HexFixedLower
  , word12HexFixedUpper
  ) where

import Control.Monad.ST
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif
import Data.Word
import Data.Bits
import Data.Char (ord)
import Data.Word.Synthetic.Word12 (Word12)
import Data.Text (Text)
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified Data.Text.Array as A
import qualified Data.Text.Internal as TI
import qualified Data.Text.Builder.Common.Internal as I

data Builder a where
  BuilderStatic :: Text -> Builder a
  BuilderFunction :: Text -> (forall s. Int -> A.MArray s -> a -> ST s ()) -> Builder a

{-# INLINE appendBuilder #-}
appendBuilder :: Builder a -> Builder a -> Builder a
appendBuilder :: Builder a -> Builder a -> Builder a
appendBuilder Builder a
x Builder a
y = case Builder a
x of
  BuilderStatic Text
t1 -> case Builder a
y of
    BuilderStatic Text
t2 -> Text -> Builder a
forall a. Text -> Builder a
BuilderStatic (Text
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t2)
    BuilderFunction Text
t2 forall s. Int -> MArray s -> a -> ST s ()
f ->
      let len1 :: Int
len1 = Text -> Int
I.portableTextLength Text
t1
       in Text -> (forall s. Int -> MArray s -> a -> ST s ()) -> Builder a
forall a.
Text -> (forall s. Int -> MArray s -> a -> ST s ()) -> Builder a
BuilderFunction (Text
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t2) (\Int
ix MArray s
marr a
a -> Int -> MArray s -> a -> ST s ()
forall s. Int -> MArray s -> a -> ST s ()
f (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len1) MArray s
marr a
a)
  BuilderFunction Text
t1 forall s. Int -> MArray s -> a -> ST s ()
f1 -> case Builder a
y of
    BuilderStatic Text
t2 -> Text -> (forall s. Int -> MArray s -> a -> ST s ()) -> Builder a
forall a.
Text -> (forall s. Int -> MArray s -> a -> ST s ()) -> Builder a
BuilderFunction (Text
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t2) forall s. Int -> MArray s -> a -> ST s ()
f1
    BuilderFunction Text
t2 forall s. Int -> MArray s -> a -> ST s ()
f2 ->
      let len1 :: Int
len1 = Text -> Int
I.portableTextLength Text
t1
       in Text -> (forall s. Int -> MArray s -> a -> ST s ()) -> Builder a
forall a.
Text -> (forall s. Int -> MArray s -> a -> ST s ()) -> Builder a
BuilderFunction (Text
t1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t2) (\Int
ix MArray s
marr a
a -> Int -> MArray s -> a -> ST s ()
forall s. Int -> MArray s -> a -> ST s ()
f1 Int
ix MArray s
marr a
a ST s () -> ST s () -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> MArray s -> a -> ST s ()
forall s. Int -> MArray s -> a -> ST s ()
f2 (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len1) MArray s
marr a
a)

instance Semigroup.Semigroup (Builder a) where
  {-# INLINE (<>) #-}
  <> :: Builder a -> Builder a -> Builder a
(<>) = Builder a -> Builder a -> Builder a
forall a. Builder a -> Builder a -> Builder a
appendBuilder

instance Monoid (Builder a) where
  {-# INLINE mempty #-}
  mempty :: Builder a
mempty = Text -> Builder a
forall a. Text -> Builder a
BuilderStatic Text
Text.empty
  {-# INLINE mappend #-}
  mappend :: Builder a -> Builder a -> Builder a
mappend = Builder a -> Builder a -> Builder a
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

fromText :: Text -> Builder a
fromText :: Text -> Builder a
fromText = Text -> Builder a
forall a. Text -> Builder a
BuilderStatic
{-# INLINE fromText #-}

contramapBuilder :: (b -> a) -> Builder a -> Builder b
contramapBuilder :: (b -> a) -> Builder a -> Builder b
contramapBuilder b -> a
f Builder a
x = case Builder a
x of
  BuilderStatic Text
t -> Text -> Builder b
forall a. Text -> Builder a
BuilderStatic Text
t
  BuilderFunction Text
t forall s. Int -> MArray s -> a -> ST s ()
g -> Text -> (forall s. Int -> MArray s -> b -> ST s ()) -> Builder b
forall a.
Text -> (forall s. Int -> MArray s -> a -> ST s ()) -> Builder a
BuilderFunction Text
t (\Int
ix MArray s
marr b
b -> Int -> MArray s -> a -> ST s ()
forall s. Int -> MArray s -> a -> ST s ()
g Int
ix MArray s
marr (b -> a
f b
b))
{-# INLINE contramapBuilder #-}

run :: Builder a -> a -> Text
run :: Builder a -> a -> Text
run Builder a
x = case Builder a
x of
  BuilderStatic Text
t -> \a
_ -> Text
t
  BuilderFunction Text
t forall s. Int -> MArray s -> a -> ST s ()
f ->
    let (Array
inArr, Int
len) = Text -> (Array, Int)
I.portableUntext Text
t
     in \a
a ->
          let outArr :: Array
outArr = (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
len
                MArray s -> Int -> Array -> Int -> Int -> ST s ()
forall s. MArray s -> Int -> Array -> Int -> Int -> ST s ()
A.copyI MArray s
marr Int
0 Array
inArr Int
0 Int
len
                Int -> MArray s -> a -> ST s ()
forall s. Int -> MArray s -> a -> ST s ()
f Int
0 MArray s
marr a
a
                MArray s -> ST s Array
forall s. MArray s -> ST s Array
A.unsafeFreeze MArray s
marr
           in Array -> Int -> Int -> Text
TI.text Array
outArr Int
0 Int
len
{-# INLINE run #-}

word8HexFixedUpper :: Builder Word8
word8HexFixedUpper :: Builder Word8
word8HexFixedUpper = Bool -> Builder Word8
word8HexFixedGeneral Bool
True
{-# INLINE word8HexFixedUpper #-}

word8HexFixedLower :: Builder Word8
word8HexFixedLower :: Builder Word8
word8HexFixedLower = Bool -> Builder Word8
word8HexFixedGeneral Bool
False
{-# INLINE word8HexFixedLower #-}

-- The Bool is True if the hex digits are upper case.
word8HexFixedGeneral :: Bool -> Builder Word8
word8HexFixedGeneral :: Bool -> Builder Word8
word8HexFixedGeneral Bool
upper =
  Text
-> (forall s. Int -> MArray s -> Word8 -> ST s ()) -> Builder Word8
forall a.
Text -> (forall s. Int -> MArray s -> a -> ST s ()) -> Builder a
BuilderFunction (String -> Text
Text.pack String
"--") ((forall s. Int -> MArray s -> Word8 -> ST s ()) -> Builder Word8)
-> (forall s. Int -> MArray s -> Word8 -> ST s ()) -> Builder Word8
forall a b. (a -> b) -> a -> b
$ \Int
i MArray s
marr Word8
w -> do
    let ix :: Int
ix = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
unsafeShiftL (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w) Int
1
        ix2 :: Int
ix2 = Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        arr :: Array
arr = if Bool
upper then Array
I.hexValuesWord8Upper else Array
I.hexValuesWord8Lower
    MArray s -> Int -> Word16 -> ST s ()
forall s. MArray s -> Int -> Word16 -> ST s ()
A.unsafeWrite MArray s
marr Int
i (Array -> Int -> Word16
A.unsafeIndex Array
arr Int
ix)
    MArray s -> Int -> Word16 -> ST s ()
forall s. MArray s -> Int -> Word16 -> ST s ()
A.unsafeWrite MArray s
marr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Array -> Int -> Word16
A.unsafeIndex Array
arr Int
ix2)
{-# INLINE word8HexFixedGeneral #-}

-- | Characters outside the basic multilingual plane are not handled
--   correctly by this function. They will not cause a program to crash;
--   instead, the character will have the upper bits masked out.
charBmp :: Builder Char
charBmp :: Builder Char
charBmp =
  Text
-> (forall s. Int -> MArray s -> Char -> ST s ()) -> Builder Char
forall a.
Text -> (forall s. Int -> MArray s -> a -> ST s ()) -> Builder a
BuilderFunction (String -> Text
Text.pack String
"-") ((forall s. Int -> MArray s -> Char -> ST s ()) -> Builder Char)
-> (forall s. Int -> MArray s -> Char -> ST s ()) -> Builder Char
forall a b. (a -> b) -> a -> b
$ \Int
i MArray s
marr Char
c -> MArray s -> Int -> Word16 -> ST s ()
forall s. MArray s -> Int -> Word16 -> ST s ()
A.unsafeWrite MArray s
marr Int
i (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c))
{-# INLINE charBmp #-}

word12HexFixedGeneral :: Bool -> Builder Word12
word12HexFixedGeneral :: Bool -> Builder Word12
word12HexFixedGeneral Bool
upper =
  Text
-> (forall s. Int -> MArray s -> Word12 -> ST s ())
-> Builder Word12
forall a.
Text -> (forall s. Int -> MArray s -> a -> ST s ()) -> Builder a
BuilderFunction (String -> Text
Text.pack String
"---") ((forall s. Int -> MArray s -> Word12 -> ST s ())
 -> Builder Word12)
-> (forall s. Int -> MArray s -> Word12 -> ST s ())
-> Builder Word12
forall a b. (a -> b) -> a -> b
$ \Int
i MArray s
marr Word12
w -> do
    let !wInt :: Int
wInt = Word12 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word12
w
        !ix :: Int
ix = Int
wInt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wInt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wInt
        !arr :: Array
arr = if Bool
upper then Array
I.hexValuesWord12Upper else Array
I.hexValuesWord12Lower
    MArray s -> Int -> Word16 -> ST s ()
forall s. MArray s -> Int -> Word16 -> ST s ()
A.unsafeWrite MArray s
marr Int
i (Array -> Int -> Word16
A.unsafeIndex Array
arr Int
ix)
    MArray s -> Int -> Word16 -> ST s ()
forall s. MArray s -> Int -> Word16 -> ST s ()
A.unsafeWrite MArray s
marr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Array -> Int -> Word16
A.unsafeIndex Array
arr (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
    MArray s -> Int -> Word16 -> ST s ()
forall s. MArray s -> Int -> Word16 -> ST s ()
A.unsafeWrite MArray s
marr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Array -> Int -> Word16
A.unsafeIndex Array
arr (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2))
{-# INLINE word12HexFixedGeneral #-}

word12HexFixedUpper :: Builder Word12
word12HexFixedUpper :: Builder Word12
word12HexFixedUpper = Bool -> Builder Word12
word12HexFixedGeneral Bool
True
{-# INLINE word12HexFixedUpper #-}

word12HexFixedLower :: Builder Word12
word12HexFixedLower :: Builder Word12
word12HexFixedLower = Bool -> Builder Word12
word12HexFixedGeneral Bool
False
{-# INLINE word12HexFixedLower #-}