feat: more PrettySerialize instances
This commit is contained in:
parent
b9918701fd
commit
93473c9ac6
3 changed files with 99 additions and 18 deletions
|
@ -20,7 +20,10 @@ extra-source-files:
|
||||||
description: Please see the README on GitHub at <https://github.com/githubuser/pretty-parse#readme>
|
description: Please see the README on GitHub at <https://github.com/githubuser/pretty-parse#readme>
|
||||||
|
|
||||||
dependencies:
|
dependencies:
|
||||||
|
- array
|
||||||
- base >= 4.7 && < 5
|
- base >= 4.7 && < 5
|
||||||
|
- bytestring
|
||||||
|
- containers
|
||||||
- text
|
- text
|
||||||
|
|
||||||
ghc-options:
|
ghc-options:
|
||||||
|
|
|
@ -33,7 +33,10 @@ library
|
||||||
src
|
src
|
||||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
|
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.7 && <5
|
array
|
||||||
|
, base >=4.7 && <5
|
||||||
|
, bytestring
|
||||||
|
, containers
|
||||||
, text
|
, text
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
@ -45,7 +48,10 @@ executable pretty-parse-exe
|
||||||
app
|
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
|
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:
|
build-depends:
|
||||||
base >=4.7 && <5
|
array
|
||||||
|
, base >=4.7 && <5
|
||||||
|
, bytestring
|
||||||
|
, containers
|
||||||
, pretty-parse
|
, pretty-parse
|
||||||
, text
|
, text
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -59,7 +65,10 @@ test-suite pretty-parse-test
|
||||||
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
|
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:
|
build-depends:
|
||||||
base >=4.7 && <5
|
array
|
||||||
|
, base >=4.7 && <5
|
||||||
|
, bytestring
|
||||||
|
, containers
|
||||||
, pretty-parse
|
, pretty-parse
|
||||||
, text
|
, text
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
|
@ -13,13 +13,14 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE DerivingVia #-}
|
{-# 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.Builder (Builder)
|
||||||
import Data.Text.Lazy (Text)
|
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 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 qualified Data.Text.Lazy.Builder as Builder
|
||||||
import Control.Monad ((<$!>))
|
import Control.Monad ((<$!>), forM_)
|
||||||
import qualified Data.Text.Lazy as Text
|
import qualified Data.Text.Lazy as Text
|
||||||
import Data.String (IsString(fromString))
|
import Data.String (IsString(fromString))
|
||||||
import GHC.TypeLits (symbolVal, KnownSymbol)
|
import GHC.TypeLits (symbolVal, KnownSymbol)
|
||||||
|
@ -30,6 +31,16 @@ import Numeric.Natural (Natural)
|
||||||
import Data.Functor.Identity (Identity)
|
import Data.Functor.Identity (Identity)
|
||||||
import Data.Functor.Const (Const)
|
import Data.Functor.Const (Const)
|
||||||
import Data.Functor.Compose (Compose)
|
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
|
type Indentation = Word
|
||||||
|
|
||||||
|
@ -103,7 +114,7 @@ recordField labelField dumpField = do
|
||||||
pure result
|
pure result
|
||||||
|
|
||||||
unnamedField :: Serializer a -> Serializer a
|
unnamedField :: Serializer a -> Serializer a
|
||||||
unnamedField = recordField dumpSerializer
|
unnamedField = recordField serializer
|
||||||
|
|
||||||
namedField :: Text -> Serializer a -> Serializer a
|
namedField :: Text -> Serializer a -> Serializer a
|
||||||
namedField name = recordField (const $ emit name)
|
namedField name = recordField (const $ emit name)
|
||||||
|
@ -111,6 +122,7 @@ namedField name = recordField (const $ emit name)
|
||||||
inConstructor :: Text -> Serializer a -> Serializer a
|
inConstructor :: Text -> Serializer a -> Serializer a
|
||||||
inConstructor name body = do
|
inConstructor name body = do
|
||||||
oldIndentation <- indentation <$!> getSerializerState
|
oldIndentation <- indentation <$!> getSerializerState
|
||||||
|
emit "::"
|
||||||
emit name
|
emit name
|
||||||
|
|
||||||
-- increase the indentation
|
-- increase the indentation
|
||||||
|
@ -133,24 +145,27 @@ inConstructor name body = do
|
||||||
inDatatype :: Text -> Serializer b -> Serializer b
|
inDatatype :: Text -> Serializer b -> Serializer b
|
||||||
inDatatype name body = do
|
inDatatype name body = do
|
||||||
emit name
|
emit name
|
||||||
emit "::"
|
|
||||||
|
|
||||||
body
|
body
|
||||||
|
|
||||||
|
inDatatypeOf :: Typeable a => a -> Serializer b -> Serializer b
|
||||||
|
inDatatypeOf = inDatatype . Text.pack . show . typeOf
|
||||||
|
|
||||||
run :: Serializer () -> Text
|
run :: Serializer () -> Text
|
||||||
run (Serializer computeUnit) = Builder.toLazyText . builder . fst . computeUnit $ SerializerState {builder=mempty, indentation=0, increaseIndentation=(+4), currentFieldIndex=Nothing}
|
run (Serializer computeUnit) = Builder.toLazyText . builder . fst . computeUnit $ SerializerState {builder=mempty, indentation=0, increaseIndentation=(+4), currentFieldIndex=Nothing}
|
||||||
|
|
||||||
class PrettySerialize a where
|
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
|
newtype ShowPrettySerialize a = ShowPrettySerialize a
|
||||||
|
|
||||||
instance Show a => PrettySerialize (ShowPrettySerialize a) where
|
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 Int instance PrettySerialize Int
|
||||||
deriving via ShowPrettySerialize Int8 instance PrettySerialize Int8
|
deriving via ShowPrettySerialize Int8 instance PrettySerialize Int8
|
||||||
deriving via ShowPrettySerialize Word instance PrettySerialize Word
|
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 Integer instance PrettySerialize Integer
|
||||||
deriving via ShowPrettySerialize Natural instance PrettySerialize Natural
|
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 (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 (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 (Identity a) instance (PrettySerialize a) => PrettySerialize (Identity a)
|
||||||
deriving via Generically (Const a b) instance (PrettySerialize a) => PrettySerialize (Const a b)
|
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)
|
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
|
class GenericPrettySerialize self where
|
||||||
genericDumpSerializer :: self x -> Serializer ()
|
genericDumpSerializer :: self x -> Serializer ()
|
||||||
|
|
||||||
instance (Generic a, GenericPrettySerialize (Rep a)) => PrettySerialize (Generically a) where
|
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
|
-- unit value
|
||||||
instance GenericPrettySerialize U1 where
|
instance GenericPrettySerialize U1 where
|
||||||
|
@ -191,7 +260,7 @@ instance GenericPrettySerialize U1 where
|
||||||
-- a field
|
-- a field
|
||||||
instance (PrettySerialize a) => GenericPrettySerialize (K1 i a) where
|
instance (PrettySerialize a) => GenericPrettySerialize (K1 i a) where
|
||||||
genericDumpSerializer :: K1 i a x -> Serializer ()
|
genericDumpSerializer :: K1 i a x -> Serializer ()
|
||||||
genericDumpSerializer (K1 fieldValue) = dumpSerializer fieldValue
|
genericDumpSerializer (K1 fieldValue) = serializer fieldValue
|
||||||
|
|
||||||
-- unnamed field meta
|
-- unnamed field meta
|
||||||
instance GenericPrettySerialize a => GenericPrettySerialize (M1 tag (MetaSel Nothing isUnpacked isStrictSource isStrictCompiler) a) where
|
instance GenericPrettySerialize a => GenericPrettySerialize (M1 tag (MetaSel Nothing isUnpacked isStrictSource isStrictCompiler) a) where
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue