feat: more PrettySerialize instances

package.yaml

@@ -20,7 +20,10 @@ extra-source-files:
 description:         Please see the README on GitHub at <https://github.com/githubuser/pretty-parse#readme>
 
 dependencies:
+- array
 - base >= 4.7 && < 5
+- bytestring
+- containers
 - text
 
 ghc-options:

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

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
+  serialize :: a -> Text
-  dump = run . dumpSerializer
+  serialize = run . serializer
-  dumpSerializer :: a -> Serializer ()
+  serializer :: a -> Serializer ()
 
 newtype ShowPrettySerialize a = ShowPrettySerialize  a
 
 instance Show a => PrettySerialize (ShowPrettySerialize a) where
-  dumpSerializer :: ShowPrettySerialize a -> Serializer ()
+  serializer :: ShowPrettySerialize a -> Serializer ()
-  dumpSerializer = emit . fromString . show . (\ (ShowPrettySerialize a) -> a)
+  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
+  serializer :: Generically a -> Serializer ()
-  dump = run . dumpSerializer
+  serializer (Generically a) = genericDumpSerializer . from $ a
-  dumpSerializer :: Generically a -> Serializer ()
-  dumpSerializer (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