1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212

{-# LANGUAGE OverloadedLabels #-}

module Builder
  ( Txt (..),
    Byt (..),
    Build (..),
    buildText,
    buildTextLazy,
    buildBytes,
    buildBytesLazy,
    textT,
    stringT,
    textLazyT,
    bytesB,
    bytesLazyB,
    utf8B,
    utf8LazyB,
    utf8LenientT,
    utf8LenientLazyT,
    intDecimalT,
    intDecimalB,
    int64DecimalT,
    int64DecimalB,
    integerDecimalT,
    integerDecimalB,
    naturalDecimalT,
    naturalDecimalB,
    doubleDecimalT,
    doubleDecimalB,
    scientificDecimalT,
    scientificDecimalB,
    nominalDiffTimeSecondsT,
    intersperseT,
    intersperseT',
    intersperseB,
    intersperseB',
    padPrefixB,
    padPrefixT,
  )
where

import Control.Category qualified as Cat
import Data.ByteString.Builder qualified as Bytes
import Data.ByteString.Builder.Scientific qualified as Scientific.Bytes
import Data.ByteString.Lazy qualified as ByteStringL
import Data.ByteString.Lazy qualified as Bytes.Lazy
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import Data.Int (Int64)
import Data.Semigroupoid (Semigroupoid (o))
import Data.String
import Data.Text.Lazy qualified as Text.Lazy
import Data.Text.Lazy.Builder qualified as Text
import Data.Text.Lazy.Builder.Int qualified as Text
import Data.Text.Lazy.Builder.RealFloat qualified as Text
import Data.Text.Lazy.Builder.Scientific qualified as Scientific.Text
import Data.Time (NominalDiffTime)
import MyPrelude

newtype Txt = Txt {unTxt :: Text.Builder}
  deriving newtype (Semigroup, Monoid)

newtype Byt = Byt {unByt :: Bytes.Builder}
  deriving newtype (Semigroup, Monoid)

instance IsString Txt where
  fromString s = Txt $ Text.fromString s

instance IsString Byt where
  fromString s = Byt $ Bytes.byteString (s & fromString)

newtype Build to from = Build {unBuild :: from -> to}
  deriving newtype (Semigroup, Monoid)

instance Contravariant (Build to) where
  contramap f (Build g) = Build $ g . f

instance (IsString to) => IsString (Build to from) where
  fromString s = Build $ \_ -> s & fromString

instance (Monoid to) => Divisible (Build to) where
  divide f (Build g) (Build h) = Build $ \a -> let (b, c) = f a in g b <> h c
  conquer = Build $ \_ -> mempty


instance Semigroupoid Build where
  o (Build f) (Build g) = Build $ g . f

instance Category Build where
  id = Build id
  (.) = o

-- | Convert a 'Build Txt a' to a strict 'Text' by applying it to a value.
buildText :: Build Txt a -> a -> Text
buildText (Build f) a = f a & (.unTxt) & Text.toLazyText & toStrict

-- | Convert a 'Build Txt a' to a lazy 'Text' by applying it to a value.
buildTextLazy :: Build Txt a -> a -> Text.Lazy.Text
buildTextLazy (Build f) a = f a & (.unTxt) & Text.toLazyText


-- | Convert a 'Build Byt a' to a strict 'ByteString' by applying it to a value.
buildBytes :: Build Byt a -> a -> ByteString
buildBytes (Build f) a = f a & (.unByt) & Bytes.toLazyByteString & toStrictBytes

-- | Convert a 'Build Byt a' to a lazy 'ByteString' by applying it to a value.
buildBytesLazy :: Build Byt a -> a -> Bytes.Lazy.ByteString
buildBytesLazy (Build f) a = f a & (.unByt) & Bytes.toLazyByteString

textT :: Build Txt Text
textT = Build (Txt . Text.fromText)

stringT :: Build Txt String
stringT = Build (Txt . Text.fromString)

textLazyT :: Build Txt Text.Lazy.Text
textLazyT = Build (Txt . Text.fromLazyText)

bytesB :: Build Byt ByteString
bytesB = Build (Byt . Bytes.byteString)

bytesLazyB :: Build Byt Bytes.Lazy.ByteString
bytesLazyB = Build (Byt . Bytes.lazyByteString)

utf8LenientT :: Build Txt ByteString
utf8LenientT = bytesToTextUtf8Lenient >$< textT

utf8LenientLazyT :: Build Txt Bytes.Lazy.ByteString
utf8LenientLazyT = bytesToTextUtf8LenientLazy >$< textLazyT

utf8B :: Build Byt Text
utf8B = textToBytesUtf8 >$< bytesB

utf8LazyB :: Build Byt Text.Lazy.Text
utf8LazyB = textToBytesUtf8Lazy >$< bytesLazyB

intDecimalT :: Build Txt Int
intDecimalT = Build (Txt . Text.decimal)

intDecimalB :: Build Byt Int
intDecimalB = Build (Byt . Bytes.intDec)

int64DecimalT :: Build Txt Int64
int64DecimalT = Build (Txt . Text.decimal)

int64DecimalB :: Build Byt Int64
int64DecimalB = Build (Byt . Bytes.int64Dec)

integerDecimalT :: Build Txt Integer
integerDecimalT = Build (Txt . Text.decimal)

integerDecimalB :: Build Byt Integer
integerDecimalB = Build (Byt . Bytes.integerDec)

naturalDecimalT :: Build Txt Natural
naturalDecimalT = Build (Txt . Text.decimal)

naturalDecimalB :: Build Byt Natural
naturalDecimalB = toInteger >$< integerDecimalB

doubleDecimalT :: Build Txt Double
doubleDecimalT = Build (Txt . Text.realFloat)

doubleDecimalB :: Build Byt Double
doubleDecimalB = Build (Byt . Bytes.doubleDec)

scientificDecimalT :: Build Txt Scientific
scientificDecimalT = Build (Txt . Scientific.Text.scientificBuilder)

scientificDecimalB :: Build Byt Scientific
scientificDecimalB = Build (Byt . Scientific.Bytes.scientificBuilder)

nominalDiffTimeSecondsT :: Build Txt NominalDiffTime
nominalDiffTimeSecondsT = truncate @NominalDiffTime @Int >$< intDecimalT

-- TODO: can these be abstracted over Divisible & Semigroup? Or something?
intersperseT :: (forall b. Build Txt b) -> Build Txt a -> Build Txt [a]
intersperseT sep a = ((),) >$< intersperseT' sep a

intersperseT' :: Build Txt b -> Build Txt a -> Build Txt (b, [a])
intersperseT' (Build sep) (Build a) = Build $ \(b, as) -> Txt $ mintersperse (sep b & (.unTxt)) (fmap (a >>> (.unTxt)) as)

intersperseB :: (forall b. Build Byt b) -> Build Byt a -> Build Byt [a]
intersperseB sep a = ((),) >$< intersperseB' sep a

intersperseB' :: Build Byt b -> Build Byt a -> Build Byt (b, [a])
intersperseB' (Build sep) (Build a) = Build $ \(b, as) -> Byt $ mintersperse (sep b & (.unByt)) (fmap (a >>> (.unByt)) as)

-- | Pad the given string
--
-- ATTN: has to build the string first to figure out the length.
padPrefixB :: Natural -> Word8 -> Build Byt a -> Build Byt a
padPrefixB targetLength w8 (Build f) = Build $ \a -> do
  let builder = f a & (.unByt)
  -- TODO: assert fromIntegral does not overflow
  let tlInt = fromIntegral @Natural @Int64 targetLength
  let len = ByteStringL.length (Bytes.toLazyByteString builder)
  if len < tlInt
    then Byt $ Bytes.lazyByteString (ByteStringL.replicate (tlInt - len) w8) <> builder
    else Byt builder

-- | Pad the given string
--
-- ATTN: has to build the string first to figure out the length.
padPrefixT :: Natural -> Char -> Build Txt a -> Build Txt a
padPrefixT targetLength c (Build f) = Build $ \a -> do
  let builder = f a & (.unTxt)
  let tlInt = fromIntegral @Natural @Int64 targetLength
  let len = Text.Lazy.length (Text.toLazyText builder)
  if len < tlInt
    then Txt $ Text.fromLazyText (Text.Lazy.replicate (tlInt - len) (Text.Lazy.singleton c)) <> builder
    else Txt builder