feat(users/Profpatsch/my-prelude): add builder & divisible helpers

I’ve had enough of `show & stringToText` bullshit, let’s finally
create a trivial builder contravariant module that wraps
`Text.Builder` and `ByteString.Builder` and has a naming scheme that
does not collide with anything and that I can remember in my sleep.

Plus some experiments in making `Divisible` useful with `HasField`.

Change-Id: Ie25f78226d24eadf4c35353fe9db40b7683d82c3
Reviewed-on: https://cl.tvl.fyi/c/depot/+/12955
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

users/Profpatsch/my-prelude/default.nix

@@ -7,8 +7,10 @@ pkgs.haskellPackages.mkDerivation {
   src = depot.users.Profpatsch.exactSource ./. [
     ./my-prelude.cabal
     ./src/Aeson.hs
+    ./src/Builder.hs
     ./src/Comparison.hs
     ./src/Debug.hs
+    ./src/Divisive.hs
     ./src/Json.hs
     ./src/Json/Enc.hs
     ./src/Arg.hs
@@ -34,6 +36,7 @@ pkgs.haskellPackages.mkDerivation {
     pkgs.haskellPackages.pa-pretty
     pkgs.haskellPackages.pa-field-parser
     pkgs.haskellPackages.aeson-better-errors
+    pkgs.haskellPackages.contravariant
     pkgs.haskellPackages.foldl
     pkgs.haskellPackages.resource-pool
     pkgs.haskellPackages.error

users/Profpatsch/my-prelude/my-prelude.cabal

@@ -61,8 +61,10 @@ library
       Aeson
       Arg
       AtLeast
+      Builder
       Comparison
       Debug
+      Divisive
       Json
       Json.Enc
       Test
@@ -92,6 +94,7 @@ library
      , base64-bytestring
      , bytestring
      , containers
+     , contravariant
      , foldl
      , unordered-containers
      , resource-pool

users/Profpatsch/my-prelude/src/Builder.hs

@@ -0,0 +1,94 @@
+module Builder
+  ( TextBuilder (..),
+    BytesBuilder (..),
+    buildText,
+    buildTextLazy,
+    buildBytes,
+    buildBytesLazy,
+    textT,
+    textLazyT,
+    bytesB,
+    bytesLazyB,
+    utf8B,
+    utf8LazyB,
+    intDecimalT,
+    intDecimalNaturalT,
+  )
+where
+
+import Data.ByteString.Builder qualified as Bytes
+import Data.ByteString.Lazy qualified as Bytes.Lazy
+import Data.Functor.Contravariant
+import Data.Functor.Contravariant.Divisible
+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 MyPrelude
+
+newtype TextBuilder a = TextBuilder {unTextBuilder :: a -> Text.Builder}
+  deriving newtype (Semigroup, Monoid)
+
+instance IsString (TextBuilder a) where
+  fromString s = TextBuilder $ \_ -> s & fromString
+
+instance Contravariant TextBuilder where
+  contramap f (TextBuilder g) = TextBuilder $ g . f
+
+instance Divisible TextBuilder where
+  divide f (TextBuilder bb) (TextBuilder bc) =
+    TextBuilder $ \a -> let (b, c) = f a in bb b <> bc c
+  conquer = TextBuilder $ \_ -> mempty
+
+-- | Convert a 'TextBuilder' to a strict 'Text' by applying it to a value.
+buildText :: TextBuilder a -> a -> Text
+buildText (TextBuilder f) a = f a & Text.toLazyText & toStrict
+
+-- | Convert a 'TextBuilder' to a lazy 'Text' by applying it to a value.
+buildTextLazy :: TextBuilder a -> a -> Text.Lazy.Text
+buildTextLazy (TextBuilder f) a = f a & Text.toLazyText
+
+newtype BytesBuilder a = BytesBuilder {unBytesBuilder :: a -> Bytes.Builder}
+
+instance IsString (BytesBuilder a) where
+  fromString s = BytesBuilder $ \_ -> s & fromString
+
+instance Contravariant BytesBuilder where
+  contramap f (BytesBuilder g) = BytesBuilder $ g . f
+
+instance Divisible BytesBuilder where
+  divide f (BytesBuilder bb) (BytesBuilder bc) =
+    BytesBuilder $ \a -> let (b, c) = f a in bb b <> bc c
+  conquer = BytesBuilder $ \_ -> mempty
+
+-- | Convert a 'BytesBuilder' to a strict 'ByteString' by applying it to a value.
+buildBytes :: BytesBuilder a -> a -> ByteString
+buildBytes (BytesBuilder b) a = b a & Bytes.toLazyByteString & toStrictBytes
+
+-- | Convert a 'BytesBuilder' to a lazy 'ByteString' by applying it to a value.
+buildBytesLazy :: BytesBuilder a -> a -> Bytes.Lazy.ByteString
+buildBytesLazy (BytesBuilder b) a = b a & Bytes.toLazyByteString
+
+textT :: TextBuilder Text
+textT = TextBuilder Text.fromText
+
+textLazyT :: TextBuilder Text.Lazy.Text
+textLazyT = TextBuilder Text.fromLazyText
+
+bytesB :: BytesBuilder ByteString
+bytesB = BytesBuilder Bytes.byteString
+
+bytesLazyB :: BytesBuilder Bytes.Lazy.ByteString
+bytesLazyB = BytesBuilder Bytes.lazyByteString
+
+utf8B :: BytesBuilder Text
+utf8B = textToBytesUtf8 >$< bytesB
+
+utf8LazyB :: BytesBuilder Text.Lazy.Text
+utf8LazyB = textToBytesUtf8Lazy >$< bytesLazyB
+
+intDecimalT :: TextBuilder Int
+intDecimalT = TextBuilder Text.decimal
+
+intDecimalNaturalT :: TextBuilder Natural
+intDecimalNaturalT = TextBuilder Text.decimal

users/Profpatsch/my-prelude/src/Divisive.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Divisive where
+
+import Data.Functor.Contravariant
+import Data.Functor.Contravariant.Divisible
+import GHC.Records (HasField (getField))
+import Label
+
+-- | Combine two divisibles into a struct with any two labelled fields.
+divide2 ::
+  forall l1 l2 t1 t2 d r.
+  (Divisible d, HasField l1 r t1, HasField l2 r t2) =>
+  d t1 ->
+  d t2 ->
+  d r
+divide2 = divide (\r -> (getField @l1 r, getField @l2 r))
+
+-- | Combine two divisibles into a 'T2' with any two labelled fields.
+dt2 ::
+  forall l1 l2 t1 t2 d.
+  (Divisible d) =>
+  d t1 ->
+  d t2 ->
+  d (T2 l1 t1 l2 t2)
+dt2 = divide (\(T2 a b) -> (getField @l1 a, getField @l2 b))
+
+-- | Combine three divisibles into a struct with any three labelled fields.
+divide3 :: forall l1 l2 l3 t1 t2 t3 d r. (Divisible d, HasField l1 r t1, HasField l2 r t2, HasField l3 r t3) => d t1 -> d t2 -> d t3 -> d r
+divide3 a b c = adapt >$< a `divided` b `divided` c
+  where
+    adapt r = ((getField @l1 r, getField @l2 r), getField @l3 r)
+
+-- | Combine three divisibles into a 'T3' with any three labelled fields.
+dt3 ::
+  forall l1 l2 l3 t1 t2 t3 d.
+  (Divisible d) =>
+  d t1 ->
+  d t2 ->
+  d t3 ->
+  d (T3 l1 t1 l2 t2 l3 t3)
+dt3 a b c = adapt >$< a `divided` b `divided` c
+  where
+    adapt (T3 a' b' c') = ((getField @l1 a', getField @l2 b'), getField @l3 c')

users/Profpatsch/my-prelude/src/MyPrelude.hs

@@ -140,6 +140,7 @@ module MyPrelude
     contramap,
     (>$<),
     (>&<),
+    module Divisive,
     Profunctor,
     dimap,
     lmap,
@@ -222,6 +223,7 @@ import Data.Traversable (for)
 import Data.Vector (Vector)
 import Data.Void (Void, absurd)
 import Data.Word (Word8)
+import Divisive
 import GHC.Exception (errorCallWithCallStackException)
 import GHC.Exts (Any, RuntimeRep, TYPE, raise#)
 import GHC.Generics (Generic)