{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}
module Std.Data.TextBuilder
(
ToText(..), toText, toBuilder, toBytes, toString
, Str(..)
, TextBuilder
, getBuilder
, unsafeFromBuilder
, buildText
, stringUTF8, charUTF8, string7, char7, text
, 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 qualified Data.Scientific as Sci
import Data.String
import Data.Bits
import Data.Data (Data(..))
import Data.Fixed
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.List.NonEmpty as 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 GHC.Natural
import GHC.Generics
import Data.Version
import Data.Primitive.Types
import qualified Std.Data.Builder as B
import qualified Std.Data.Builder.Numeric as B
import qualified Std.Data.Text.Base as T
import Std.Data.Text.Base (Text(..))
import Std.Data.Generics.Utils
import qualified Std.Data.Vector.Base as V
import Text.Read (Read(..))
import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..))
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 ToText (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)
newtype Str = Str { chrs :: [Char] } deriving stock (Eq, Ord, Data, Typeable, Generic)
instance Show Str where show = show . chrs
instance Read Str where readPrec = Str <$> readPrec
instance ToText Str where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = TextBuilder . B.string8 . show
class ToText 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 "Std.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 ToText 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
toText :: ToText a => a -> Text
{-# INLINE toText #-}
toText = buildText . toTextBuilder 0
toBuilder :: ToText a => a -> B.Builder ()
{-# INLINE toBuilder #-}
toBuilder = getBuilder . toTextBuilder 0
toBytes :: ToText a => a -> V.Bytes
{-# INLINE toBytes #-}
toBytes = B.buildBytes . toBuilder
toString :: ToText a => a -> String
{-# INLINE toString #-}
toString = T.unpack . toText
instance ToText Bool where
{-# INLINE toTextBuilder #-}
toTextBuilder _ True = TextBuilder "True"
toTextBuilder _ _ = TextBuilder "False"
instance ToText Char where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = TextBuilder . B.string8 . show
instance ToText Double where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = double;}
instance ToText Float where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = float;}
instance ToText Int where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ToText Int8 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ToText Int16 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ToText Int32 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ToText Int64 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ToText Word where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ToText Word8 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ToText Word16 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ToText Word32 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ToText Word64 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;}
instance ToText Integer where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = integer;}
instance ToText Natural where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = integer . fromIntegral}
instance ToText Ordering where
{-# INLINE toTextBuilder #-}
toTextBuilder _ GT = TextBuilder "GT"
toTextBuilder _ EQ = TextBuilder "EQ"
toTextBuilder _ _ = TextBuilder "LT"
instance ToText () where
{-# INLINE toTextBuilder #-}
toTextBuilder _ () = TextBuilder "()"
instance ToText Version where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = stringUTF8 . show
instance ToText Text where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = stringUTF8 . show
instance ToText Sci.Scientific where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = scientific
instance ToText a => ToText [a] where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = square . intercalateList comma (toTextBuilder 0)
instance ToText a => ToText (V.Vector a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0)
instance (Prim a, ToText a) => ToText (V.PrimVector a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0)
instance (ToText a, ToText b) => ToText (a, b) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ (a, b) = paren $ toTextBuilder 0 a
>> comma >> toTextBuilder 0 b
instance (ToText a, ToText b, ToText c) => ToText (a, b, c) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ (a, b, c) = paren $ toTextBuilder 0 a
>> comma >> toTextBuilder 0 b
>> comma >> toTextBuilder 0 c
instance (ToText a, ToText b, ToText c, ToText d) => ToText (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 (ToText a, ToText b, ToText c, ToText d, ToText e) => ToText (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 (ToText a, ToText b, ToText c, ToText d, ToText e, ToText f) => ToText (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 (ToText a, ToText b, ToText c, ToText d, ToText e, ToText f, ToText g) => ToText (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 ToText a => ToText (Maybe a) where
{-# INLINE toTextBuilder #-}
toTextBuilder p (Just x) = parenWhen (p > 10) $ do TextBuilder "Just "
toTextBuilder 11 x
toTextBuilder _ _ = TextBuilder "Nothing"
instance (ToText a, ToText b) => ToText (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 (ToText a, Integral a) => ToText (Ratio a) where
{-# INLINE toTextBuilder #-}
toTextBuilder p r = parenWhen (p > 10) $ do toTextBuilder 8 (numerator r)
TextBuilder " % "
toTextBuilder 8 (denominator r)
instance HasResolution a => ToText (Fixed a) where
{-# INLINE toTextBuilder #-}
toTextBuilder _ = TextBuilder . B.string8 . show
deriving anyclass instance ToText a => ToText (Semigroup.Min a)
deriving anyclass instance ToText a => ToText (Semigroup.Max a)
deriving anyclass instance ToText a => ToText (Semigroup.First a)
deriving anyclass instance ToText a => ToText (Semigroup.Last a)
deriving anyclass instance ToText a => ToText (Semigroup.WrappedMonoid a)
deriving anyclass instance ToText a => ToText (Semigroup.Dual a)
deriving anyclass instance ToText a => ToText (Monoid.First a)
deriving anyclass instance ToText a => ToText (Monoid.Last a)
deriving anyclass instance ToText a => ToText (NonEmpty a)
deriving anyclass instance ToText a => ToText (Identity a)
deriving anyclass instance ToText a => ToText (Const a b)
deriving anyclass instance ToText (Proxy a)
deriving anyclass instance ToText b => ToText (Tagged a b)
deriving anyclass instance ToText (f (g a)) => ToText (Compose f g a)
deriving anyclass instance (ToText (f a), ToText (g a)) => ToText (Product f g a)
deriving anyclass instance (ToText (f a), ToText (g a), ToText a) => ToText (Sum f g a)