From 93473c9ac69c20053d9fbe1b8a0ee199980cc435 Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Wed, 20 Aug 2025 19:25:01 +0200 Subject: [PATCH] feat: more PrettySerialize instances --- package.yaml | 3 ++ pretty-parse.cabal | 15 +++++-- src/Pretty/Serialize.hs | 99 ++++++++++++++++++++++++++++++++++------- 3 files changed, 99 insertions(+), 18 deletions(-) diff --git a/package.yaml b/package.yaml index e55b49d..39c5309 100644 --- a/package.yaml +++ b/package.yaml @@ -20,7 +20,10 @@ extra-source-files: description: Please see the README on GitHub at dependencies: +- array - base >= 4.7 && < 5 +- bytestring +- containers - text ghc-options: diff --git a/pretty-parse.cabal b/pretty-parse.cabal index 313dbfd..29fc070 100644 --- a/pretty-parse.cabal +++ b/pretty-parse.cabal @@ -33,7 +33,10 @@ library src ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - base >=4.7 && <5 + array + , base >=4.7 && <5 + , bytestring + , containers , text default-language: Haskell2010 @@ -45,7 +48,10 @@ executable pretty-parse-exe app ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + array + , base >=4.7 && <5 + , bytestring + , containers , pretty-parse , text default-language: Haskell2010 @@ -59,7 +65,10 @@ test-suite pretty-parse-test test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + array + , base >=4.7 && <5 + , bytestring + , containers , pretty-parse , text default-language: Haskell2010 diff --git a/src/Pretty/Serialize.hs b/src/Pretty/Serialize.hs index d04e39d..c406b68 100644 --- a/src/Pretty/Serialize.hs +++ b/src/Pretty/Serialize.hs @@ -13,13 +13,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingVia #-} -module Pretty.Serialize (Serializer, PrettySerialize(..), ShowPrettySerialize(..), run, emit) where +{-# LANGUAGE TypeFamilies #-} +module Pretty.Serialize (Serializer, PrettySerialize(..), ShowPrettySerialize(..), run, emit, KeyValueSerialize(..)) where import Data.Text.Lazy.Builder (Builder) import Data.Text.Lazy (Text) import GHC.Generics (U1, K1 (K1), Generically (Generically), Generic (Rep), from, M1 (M1), Meta(MetaSel, MetaCons, MetaData), (:+:) (L1, R1), (:*:) ((:*:))) import qualified Data.Text.Lazy.Builder as Builder -import Control.Monad ((<$!>)) +import Control.Monad ((<$!>), forM_) import qualified Data.Text.Lazy as Text import Data.String (IsString(fromString)) import GHC.TypeLits (symbolVal, KnownSymbol) @@ -30,6 +31,16 @@ import Numeric.Natural (Natural) import Data.Functor.Identity (Identity) import Data.Functor.Const (Const) import Data.Functor.Compose (Compose) +import Data.Kind (Type) +import Data.List (List) +import Data.Typeable (typeOf, Typeable) +import qualified Data.Array.IArray as Data.IArray +import Data.Tuple (Solo) +import qualified Data.Text as Strict +import Data.Set (Set) +import qualified Data.Set as Set +import Data.ByteString.Lazy (LazyByteString) +import Data.ByteString (ByteString) type Indentation = Word @@ -103,7 +114,7 @@ recordField labelField dumpField = do pure result unnamedField :: Serializer a -> Serializer a -unnamedField = recordField dumpSerializer +unnamedField = recordField serializer namedField :: Text -> Serializer a -> Serializer a namedField name = recordField (const $ emit name) @@ -111,6 +122,7 @@ namedField name = recordField (const $ emit name) inConstructor :: Text -> Serializer a -> Serializer a inConstructor name body = do oldIndentation <- indentation <$!> getSerializerState + emit "::" emit name -- increase the indentation @@ -133,24 +145,27 @@ inConstructor name body = do inDatatype :: Text -> Serializer b -> Serializer b inDatatype name body = do emit name - emit "::" - + body +inDatatypeOf :: Typeable a => a -> Serializer b -> Serializer b +inDatatypeOf = inDatatype . Text.pack . show . typeOf + run :: Serializer () -> Text run (Serializer computeUnit) = Builder.toLazyText . builder . fst . computeUnit $ SerializerState {builder=mempty, indentation=0, increaseIndentation=(+4), currentFieldIndex=Nothing} class PrettySerialize a where - dump :: a -> Text - dump = run . dumpSerializer - dumpSerializer :: a -> Serializer () + serialize :: a -> Text + serialize = run . serializer + serializer :: a -> Serializer () newtype ShowPrettySerialize a = ShowPrettySerialize a instance Show a => PrettySerialize (ShowPrettySerialize a) where - dumpSerializer :: ShowPrettySerialize a -> Serializer () - dumpSerializer = emit . fromString . show . (\ (ShowPrettySerialize a) -> a) + serializer :: ShowPrettySerialize a -> Serializer () + serializer = emit . fromString . show . (\ (ShowPrettySerialize a) -> a) +-- numbers deriving via ShowPrettySerialize Int instance PrettySerialize Int deriving via ShowPrettySerialize Int8 instance PrettySerialize Int8 deriving via ShowPrettySerialize Word instance PrettySerialize Word @@ -167,21 +182,75 @@ deriving via ShowPrettySerialize Word64 instance PrettySerialize Word64 deriving via ShowPrettySerialize Integer instance PrettySerialize Integer deriving via ShowPrettySerialize Natural instance PrettySerialize Natural +-- text +deriving via ShowPrettySerialize Text instance PrettySerialize Text +deriving via ShowPrettySerialize ByteString instance PrettySerialize ByteString +deriving via ShowPrettySerialize Strict.Text instance PrettySerialize Strict.Text +deriving via ShowPrettySerialize LazyByteString instance PrettySerialize LazyByteString +-- tuples +deriving via Generically (Solo a) instance PrettySerialize a => PrettySerialize (Solo a) +deriving via Generically (a, b) instance (PrettySerialize a, PrettySerialize b) => PrettySerialize (a, b) + +-- functors deriving via Generically (Maybe a) instance PrettySerialize a => PrettySerialize (Maybe a) deriving via Generically (Either l r) instance (PrettySerialize l, PrettySerialize r) => PrettySerialize (Either l r) deriving via Generically (Identity a) instance (PrettySerialize a) => PrettySerialize (Identity a) deriving via Generically (Const a b) instance (PrettySerialize a) => PrettySerialize (Const a b) deriving via Generically (Compose a b c) instance (PrettySerialize (a (b c))) => PrettySerialize (Compose a b c) +-- containers + +instance (Typeable a, PrettySerialize a) => PrettySerialize (Set a) where + serializer :: Set a -> Serializer () + serializer set = do + inDatatypeOf set $ do + namedField "elements" $ do + serializer $ Set.toList set + +class ExtractMappings a where + type KeyType a :: Type + type ValueType a :: Type + keyValuePairs :: a -> List (KeyType a, ValueType a) + +instance Data.IArray.Ix index => ExtractMappings (Data.IArray.Array index element) where + + type KeyType (Data.IArray.Array index element) = index + + type ValueType (Data.IArray.Array index element) = element + + keyValuePairs :: Data.IArray.Array index element -> [(KeyType (Data.IArray.Array index element), ValueType (Data.IArray.Array index element))] + keyValuePairs = Data.IArray.assocs + +instance ExtractMappings (List a) where + type KeyType (List a) = Natural + type ValueType (List a) = a + + keyValuePairs :: [a] -> [(KeyType [a], ValueType [a])] + keyValuePairs = zip [0..] + +newtype KeyValueSerialize a = KeyValueSerialize a + + +instance (ExtractMappings a, Typeable a, PrettySerialize (KeyType a), PrettySerialize (ValueType a)) => PrettySerialize (KeyValueSerialize a) where + serializer :: KeyValueSerialize a -> Serializer () + serializer (KeyValueSerialize mapping) = do + inDatatypeOf mapping $ do + forM_ (keyValuePairs mapping) $ \ (key, value) -> do + serializer key + emit " = " + serializer value + +deriving via KeyValueSerialize (Data.IArray.Array index element) instance (Data.IArray.Ix index, Typeable index, Typeable element, PrettySerialize index, PrettySerialize element) => PrettySerialize (Data.IArray.Array index element) +deriving via KeyValueSerialize (List a) instance (Typeable a, PrettySerialize a) => PrettySerialize (List a) + + class GenericPrettySerialize self where genericDumpSerializer :: self x -> Serializer () instance (Generic a, GenericPrettySerialize (Rep a)) => PrettySerialize (Generically a) where - dump :: Generically a -> Text - dump = run . dumpSerializer - dumpSerializer :: Generically a -> Serializer () - dumpSerializer (Generically a) = genericDumpSerializer . from $ a + serializer :: Generically a -> Serializer () + serializer (Generically a) = genericDumpSerializer . from $ a -- unit value instance GenericPrettySerialize U1 where @@ -191,7 +260,7 @@ instance GenericPrettySerialize U1 where -- a field instance (PrettySerialize a) => GenericPrettySerialize (K1 i a) where genericDumpSerializer :: K1 i a x -> Serializer () - genericDumpSerializer (K1 fieldValue) = dumpSerializer fieldValue + genericDumpSerializer (K1 fieldValue) = serializer fieldValue -- unnamed field meta instance GenericPrettySerialize a => GenericPrettySerialize (M1 tag (MetaSel Nothing isUnpacked isStrictSource isStrictCompiler) a) where