module Z.Data.Text.ShowT
(
ShowT(..), showT, toBuilder, toBytes, toString
, TextBuilder
, getBuilder
, unsafeFromBuilder
, buildText
, stringUTF8, charUTF8, string7, char7, text, escapeTextJSON
, B.IFormat(..)
, B.defaultIFormat
, B.Padding(..)
, int
, intWith
, integer
, hex, heX
, B.FFormat(..)
, double
, doubleWith
, float
, floatWith
, scientific
, scientificWith
, paren, parenWhen, curly, square, angle, quotes, squotes, colon, comma, intercalateVec, intercalateList
) where
import Control.Monad
import Control.Monad.ST.Unsafe (unsafeIOToST)
import qualified Data.Scientific as Sci
import Data.String
import Data.Bits
import Data.Fixed
import Data.Primitive.PrimArray
import Data.Functor.Compose
import Data.Functor.Const
import Data.Functor.Identity
import Data.Functor.Product
import Data.Functor.Sum
import Data.Int
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Monoid as Monoid
import Data.Proxy (Proxy(..))
import Data.Ratio (Ratio, numerator, denominator)
import Data.Tagged (Tagged (..))
import Data.Word
import qualified Data.Semigroup as Semigroup
import Data.Typeable
import Foreign.C.Types
import GHC.Exts
import GHC.Natural
import GHC.Generics
import GHC.Stack
import Data.Version
import System.Exit
import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..))
import Data.Primitive.Types
import qualified Z.Data.Builder.Base as B
import qualified Z.Data.Builder.Numeric as B
import qualified Z.Data.Text.Base as T
import Z.Data.Text.Base (Text(..))
import qualified Z.Data.Array as A
import qualified Z.Data.Vector.Base as V
#define DOUBLE_QUOTE 34
newtype TextBuilder a = TextBuilder { getBuilder :: B.Builder a }
deriving newtype (Functor, Applicative, Monad)
deriving newtype instance Semigroup (TextBuilder ())
deriving newtype instance Monoid (TextBuilder ())
instance (a ~ ()) => IsString (TextBuilder a) where
{-# INLINE fromString #-}
fromString = TextBuilder <$> B.stringUTF8
instance Arbitrary (TextBuilder ()) where
arbitrary = TextBuilder . B.text <$> arbitrary
shrink b = TextBuilder . B.text <$> shrink (buildText b)
instance CoArbitrary (TextBuilder ()) where
coarbitrary = coarbitrary . buildText
instance Show (TextBuilder a) where
show = show . buildText
instance ShowT (TextBuilder a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ b = quotes (void b)
buildText :: TextBuilder a -> Text
{-# INLINE buildText #-}
buildText = Text . B.buildBytes . getBuilder
unsafeFromBuilder :: B.Builder a -> TextBuilder a
{-# INLINE unsafeFromBuilder #-}
unsafeFromBuilder = TextBuilder
stringUTF8 :: String -> TextBuilder ()
{-# INLINE stringUTF8 #-}
stringUTF8 = TextBuilder . B.stringUTF8
charUTF8 :: Char -> TextBuilder ()
{-# INLINE charUTF8 #-}
charUTF8 = TextBuilder . B.charUTF8
string7 :: String -> TextBuilder ()
{-# INLINE string7 #-}
string7 = TextBuilder . B.string7
char7 :: Char -> TextBuilder ()
{-# INLINE char7 #-}
char7 = TextBuilder . B.char7
text :: T.Text -> TextBuilder ()
{-# INLINE text #-}
text = TextBuilder . B.text
int :: (Integral a, Bounded a) => a -> TextBuilder ()
{-# INLINE int #-}
int = TextBuilder . B.int
intWith :: (Integral a, Bounded a)
=> B.IFormat
-> a
-> TextBuilder ()
{-# INLINE intWith #-}
intWith fmt x = TextBuilder $ B.intWith fmt x
integer :: Integer -> TextBuilder ()
{-# INLINE integer #-}
integer = TextBuilder . B.integer
hex :: (FiniteBits a, Integral a) => a -> TextBuilder ()
{-# INLINE hex #-}
hex = TextBuilder . B.hex
heX :: (FiniteBits a, Integral a) => a -> TextBuilder ()
{-# INLINE heX #-}
heX = TextBuilder . B.heX
float :: Float -> TextBuilder ()
{-# INLINE float #-}
float = TextBuilder . B.float
floatWith :: B.FFormat
-> Maybe Int
-> Float
-> TextBuilder ()
{-# INLINE floatWith #-}
floatWith fmt ds x = TextBuilder (B.floatWith fmt ds x)
double :: Double -> TextBuilder ()
{-# INLINE double #-}
double = TextBuilder . B.double
doubleWith :: B.FFormat
-> Maybe Int
-> Double
-> TextBuilder ()
{-# INLINE doubleWith #-}
doubleWith fmt ds x = TextBuilder (B.doubleWith fmt ds x)
scientific :: Sci.Scientific -> TextBuilder ()
{-# INLINE scientific #-}
scientific = TextBuilder . B.scientific
scientificWith :: B.FFormat
-> Maybe Int
-> Sci.Scientific
-> TextBuilder ()
{-# INLINE scientificWith #-}
scientificWith fmt ds x = TextBuilder (B.scientificWith fmt ds x)
paren :: TextBuilder () -> TextBuilder ()
{-# INLINE paren #-}
paren (TextBuilder b) = TextBuilder (B.paren b)
parenWhen :: Bool -> TextBuilder () -> TextBuilder ()
{-# INLINE parenWhen #-}
parenWhen True b = paren b
parenWhen _ b = b
curly :: TextBuilder () -> TextBuilder ()
{-# INLINE curly #-}
curly (TextBuilder b) = TextBuilder (B.curly b)
square :: TextBuilder () -> TextBuilder ()
{-# INLINE square #-}
square (TextBuilder b) = TextBuilder (B.square b)
angle :: TextBuilder () -> TextBuilder ()
{-# INLINE angle #-}
angle (TextBuilder b) = TextBuilder (B.angle b)
quotes :: TextBuilder () -> TextBuilder ()
{-# INLINE quotes #-}
quotes (TextBuilder b) = TextBuilder (B.quotes b)
squotes :: TextBuilder () -> TextBuilder ()
{-# INLINE squotes #-}
squotes (TextBuilder b) = TextBuilder (B.squotes b)
colon :: TextBuilder ()
{-# INLINE colon #-}
colon = TextBuilder B.colon
comma :: TextBuilder ()
{-# INLINE comma #-}
comma = TextBuilder B.comma
intercalateVec :: (V.Vec v a)
=> TextBuilder ()
-> (a -> TextBuilder ())
-> v a
-> TextBuilder ()
{-# INLINE intercalateVec #-}
intercalateVec (TextBuilder s) f = TextBuilder . B.intercalateVec s (getBuilder . f)
intercalateList :: TextBuilder ()
-> (a -> TextBuilder ())
-> [a]
-> TextBuilder ()
{-# INLINE intercalateList #-}
intercalateList (TextBuilder s) f = TextBuilder . B.intercalateList s (getBuilder . f)
class ShowT a where
toTextBuilder :: Int -> a -> TextBuilder ()
default toTextBuilder :: (Generic a, GToText (Rep a)) => Int -> a -> TextBuilder ()
toTextBuilder p = gToTextBuilder p . from
class GToText f where
gToTextBuilder :: Int -> f a -> TextBuilder ()
class GFieldToText f where
gFieldToTextBuilder :: B.Builder () -> Int -> f a -> B.Builder ()
instance (GFieldToText a, GFieldToText b) => GFieldToText (a :*: b) where
{-# INLINE gFieldToTextBuilder #-}
gFieldToTextBuilder sep p (a :*: b) =
gFieldToTextBuilder sep p a >> sep >> gFieldToTextBuilder sep p b
instance (GToText f) => GFieldToText (S1 (MetaSel Nothing u ss ds) f) where
{-# INLINE gFieldToTextBuilder #-}
gFieldToTextBuilder _ p (M1 x) = getBuilder (gToTextBuilder p x)
instance (GToText f, Selector (MetaSel (Just l) u ss ds)) => GFieldToText (S1 (MetaSel (Just l) u ss ds) f) where
{-# INLINE gFieldToTextBuilder #-}
gFieldToTextBuilder _ _ m1@(M1 x) =
B.stringModifiedUTF8 (selName m1) >> " = " >> getBuilder (gToTextBuilder 0 x)
instance GToText V1 where
{-# INLINE gToTextBuilder #-}
gToTextBuilder _ = error "Z.Data.TextBuilder: empty data type"
instance (GToText f, GToText g) => GToText (f :+: g) where
{-# INLINE gToTextBuilder #-}
gToTextBuilder p (L1 x) = gToTextBuilder p x
gToTextBuilder p (R1 x) = gToTextBuilder p x
instance (Constructor c) => GToText (C1 c U1) where
{-# INLINE gToTextBuilder #-}
gToTextBuilder _ m1 =
TextBuilder . B.stringModifiedUTF8 $ conName m1
instance (GFieldToText (S1 sc f), Constructor c) => GToText (C1 c (S1 sc f)) where
{-# INLINE gToTextBuilder #-}
gToTextBuilder p m1@(M1 x) =
parenWhen (p > 10) . TextBuilder $ do
B.stringModifiedUTF8 $ conName m1
B.char8 ' '
if conIsRecord m1
then B.curly $ gFieldToTextBuilder (B.char7 ',' >> B.char7 ' ') p x
else gFieldToTextBuilder (B.char7 ' ') 11 x
instance (GFieldToText (a :*: b), Constructor c) => GToText (C1 c (a :*: b)) where
{-# INLINE gToTextBuilder #-}
gToTextBuilder p m1@(M1 x) =
case conFixity m1 of
Prefix -> parenWhen (p > 10) . TextBuilder $ do
B.stringModifiedUTF8 $ conName m1
B.char8 ' '
if conIsRecord m1
then B.curly $ gFieldToTextBuilder (B.char7 ',' >> B.char7 ' ') p x
else gFieldToTextBuilder (B.char7 ' ') 11 x
Infix _ p' -> parenWhen (p > p') . TextBuilder $ do
gFieldToTextBuilder
(B.char8 ' ' >> B.stringModifiedUTF8 (conName m1) >> B.char8 ' ') (p'+1) x
instance ShowT a => GToText (K1 i a) where
{-# INLINE gToTextBuilder #-}
gToTextBuilder p (K1 x) = toTextBuilder p x
instance GToText f => GToText (D1 c f) where
{-# INLINE gToTextBuilder #-}
gToTextBuilder p (M1 x) = gToTextBuilder p x
showT :: ShowT a => a -> Text
{-# INLINE showT #-}
showT = buildText . toTextBuilder 0
toBuilder :: ShowT a => a -> B.Builder ()
{-# INLINE toBuilder #-}
toBuilder = getBuilder . toTextBuilder 0
toBytes :: ShowT a => a -> V.Bytes
{-# INLINE toBytes #-}
toBytes = B.buildBytes . toBuilder
toString :: ShowT a => a -> String
{-# INLINE toString #-}
toString = T.unpack . showT
instance ShowT Bool where
{-# INLINE toTextBuilder #-}
toTextBuilder _ True = TextBuilder "True"
toTextBuilder _ _ = TextBuilder "False"
instance ShowT Char where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = TextBuilder . B.string8 . show
instance ShowT Double where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = double;}
instance ShowT Float where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = float;}
instance ShowT Int where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ShowT Int8 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ShowT Int16 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ShowT Int32 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ShowT Int64 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ShowT Word where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ShowT Word8 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ShowT Word16 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ShowT Word32 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ShowT Word64 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ShowT Integer where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = integer;}
instance ShowT Natural where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = integer . fromIntegral}
instance ShowT Ordering where
{-# INLINE toTextBuilder #-}
toTextBuilder _ GT = TextBuilder "GT"
toTextBuilder _ EQ = TextBuilder "EQ"
toTextBuilder _ _ = TextBuilder "LT"
instance ShowT () where
{-# INLINE toTextBuilder #-}
toTextBuilder _ () = TextBuilder "()"
instance ShowT Version where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = stringUTF8 . show
instance ShowT Text where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = TextBuilder . escapeTextJSON
escapeTextJSON :: T.Text -> B.Builder ()
{-# INLINE escapeTextJSON #-}
escapeTextJSON (T.Text (V.PrimVector ba@(PrimArray ba#) s l)) = do
let siz = escape_json_string_length ba# s l
B.ensureN siz
B.Builder (\ _ k (B.Buffer mba@(MutablePrimArray mba#) i) -> do
if siz == l+2
then do
writePrimArray mba i DOUBLE_QUOTE
copyPrimArray mba (i+1) ba s l
writePrimArray mba (i+1+l) DOUBLE_QUOTE
else void $ unsafeIOToST (escape_json_string ba# s l (unsafeCoerce# mba#) i)
k () (B.Buffer mba (i+siz)))
foreign import ccall unsafe escape_json_string_length
:: ByteArray# -> Int -> Int -> Int
foreign import ccall unsafe escape_json_string
:: ByteArray# -> Int -> Int -> MutableByteArray# RealWorld -> Int -> IO Int
instance ShowT Sci.Scientific where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = scientific
instance ShowT a => ShowT [a] where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = square . intercalateList comma (toTextBuilder 0)
instance ShowT a => ShowT (A.Array a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0)
instance ShowT a => ShowT (A.SmallArray a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0)
instance (A.PrimUnlifted a, ShowT a) => ShowT (A.UnliftedArray a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0)
instance (Prim a, ShowT a) => ShowT (A.PrimArray a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0)
instance ShowT a => ShowT (V.Vector a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0)
instance (Prim a, ShowT a) => ShowT (V.PrimVector a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0)
instance (ShowT a, ShowT b) => ShowT (a, b) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ (a, b) = paren $ toTextBuilder 0 a
>> comma >> toTextBuilder 0 b
instance (ShowT a, ShowT b, ShowT c) => ShowT (a, b, c) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ (a, b, c) = paren $ toTextBuilder 0 a
>> comma >> toTextBuilder 0 b
>> comma >> toTextBuilder 0 c
instance (ShowT a, ShowT b, ShowT c, ShowT d) => ShowT (a, b, c, d) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ (a, b, c, d) = paren $ toTextBuilder 0 a
>> comma >> toTextBuilder 0 b
>> comma >> toTextBuilder 0 c
>> comma >> toTextBuilder 0 d
instance (ShowT a, ShowT b, ShowT c, ShowT d, ShowT e) => ShowT (a, b, c, d, e) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ (a, b, c, d, e) = paren $ toTextBuilder 0 a
>> comma >> toTextBuilder 0 b
>> comma >> toTextBuilder 0 c
>> comma >> toTextBuilder 0 d
>> comma >> toTextBuilder 0 e
instance (ShowT a, ShowT b, ShowT c, ShowT d, ShowT e, ShowT f) => ShowT (a, b, c, d, e, f) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ (a, b, c, d, e, f) = paren $ toTextBuilder 0 a
>> comma >> toTextBuilder 0 b
>> comma >> toTextBuilder 0 c
>> comma >> toTextBuilder 0 d
>> comma >> toTextBuilder 0 e
>> comma >> toTextBuilder 0 f
instance (ShowT a, ShowT b, ShowT c, ShowT d, ShowT e, ShowT f, ShowT g) => ShowT (a, b, c, d, e, f, g) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ (a, b, c, d, e, f, g) = paren $ toTextBuilder 0 a
>> comma >> toTextBuilder 0 b
>> comma >> toTextBuilder 0 c
>> comma >> toTextBuilder 0 d
>> comma >> toTextBuilder 0 e
>> comma >> toTextBuilder 0 f
>> comma >> toTextBuilder 0 g
instance ShowT a => ShowT (Maybe a) where
{-# INLINE toTextBuilder #-}
toTextBuilder p (Just x) = parenWhen (p > 10) $ do TextBuilder "Just "
toTextBuilder 11 x
toTextBuilder _ _ = TextBuilder "Nothing"
instance (ShowT a, ShowT b) => ShowT (Either a b) where
{-# INLINE toTextBuilder #-}
toTextBuilder p (Left x) = parenWhen (p > 10) $ do TextBuilder "Left "
toTextBuilder 11 x
toTextBuilder p (Right x) = parenWhen (p > 10) $ do TextBuilder "Right "
toTextBuilder 11 x
instance (ShowT a, Integral a) => ShowT (Ratio a) where
{-# INLINE toTextBuilder #-}
toTextBuilder p r = parenWhen (p > 10) $ do toTextBuilder 8 (numerator r)
TextBuilder " % "
toTextBuilder 8 (denominator r)
instance HasResolution a => ShowT (Fixed a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = TextBuilder . B.string8 . show
instance ShowT CallStack where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = TextBuilder . B.string8 . show
deriving newtype instance ShowT CChar
deriving newtype instance ShowT CSChar
deriving newtype instance ShowT CUChar
deriving newtype instance ShowT CShort
deriving newtype instance ShowT CUShort
deriving newtype instance ShowT CInt
deriving newtype instance ShowT CUInt
deriving newtype instance ShowT CLong
deriving newtype instance ShowT CULong
deriving newtype instance ShowT CPtrdiff
deriving newtype instance ShowT CSize
deriving newtype instance ShowT CWchar
deriving newtype instance ShowT CSigAtomic
deriving newtype instance ShowT CLLong
deriving newtype instance ShowT CULLong
deriving newtype instance ShowT CBool
deriving newtype instance ShowT CIntPtr
deriving newtype instance ShowT CUIntPtr
deriving newtype instance ShowT CIntMax
deriving newtype instance ShowT CUIntMax
deriving newtype instance ShowT CClock
deriving newtype instance ShowT CTime
deriving newtype instance ShowT CUSeconds
deriving newtype instance ShowT CSUSeconds
deriving newtype instance ShowT CFloat
deriving newtype instance ShowT CDouble
deriving anyclass instance ShowT ExitCode
deriving anyclass instance ShowT a => ShowT (Semigroup.Min a)
deriving anyclass instance ShowT a => ShowT (Semigroup.Max a)
deriving anyclass instance ShowT a => ShowT (Semigroup.First a)
deriving anyclass instance ShowT a => ShowT (Semigroup.Last a)
deriving anyclass instance ShowT a => ShowT (Semigroup.WrappedMonoid a)
deriving anyclass instance ShowT a => ShowT (Semigroup.Dual a)
deriving anyclass instance ShowT a => ShowT (Monoid.First a)
deriving anyclass instance ShowT a => ShowT (Monoid.Last a)
deriving anyclass instance ShowT a => ShowT (NonEmpty a)
deriving anyclass instance ShowT a => ShowT (Identity a)
deriving anyclass instance ShowT a => ShowT (Const a b)
deriving anyclass instance ShowT (Proxy a)
deriving anyclass instance ShowT b => ShowT (Tagged a b)
deriving anyclass instance ShowT (f (g a)) => ShowT (Compose f g a)
deriving anyclass instance (ShowT (f a), ShowT (g a)) => ShowT (Product f g a)
deriving anyclass instance (ShowT (f a), ShowT (g a), ShowT a) => ShowT (Sum f g a)