diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 2bb9f7dad..c739676c1 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/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 diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index a01464857..dba092fda 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/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 diff --git a/users/Profpatsch/my-prelude/src/Builder.hs b/users/Profpatsch/my-prelude/src/Builder.hs new file mode 100644 index 000000000..b5748de77 --- /dev/null +++ b/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 diff --git a/users/Profpatsch/my-prelude/src/Divisive.hs b/users/Profpatsch/my-prelude/src/Divisive.hs new file mode 100644 index 000000000..e4c31eb8b --- /dev/null +++ b/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') diff --git a/users/Profpatsch/my-prelude/src/MyPrelude.hs b/users/Profpatsch/my-prelude/src/MyPrelude.hs index 4a8b76ba4..661e4efc9 100644 --- a/users/Profpatsch/my-prelude/src/MyPrelude.hs +++ b/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)