From 7d2259f1974727a72e1ac623c5e17ea686e6c7d1 Mon Sep 17 00:00:00 2001 From: VegOwOtenks Date: Sat, 23 Aug 2025 19:07:58 +0200 Subject: [PATCH] feat: rewrite to continuation style --- src/Pretty/Serialize.hs | 54 +++++++++++++++++++++++------------------ 1 file changed, 30 insertions(+), 24 deletions(-) diff --git a/src/Pretty/Serialize.hs b/src/Pretty/Serialize.hs index e9e24ca..994fe01 100644 --- a/src/Pretty/Serialize.hs +++ b/src/Pretty/Serialize.hs @@ -17,12 +17,10 @@ {-# LANGUAGE BangPatterns #-} module Pretty.Serialize (Serializer, PrettySerialize(..), ShowPrettySerialize(..), run, emit, KeyValueSerialize(..), customField) where -import Data.Text.Lazy.Builder (Builder) -import Data.Text.Lazy (Text) +import Data.Text.Lazy (LazyText) 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 ((<$!>), forM_) -import qualified Data.Text.Lazy as Text +import qualified Data.Text as StrictText import Data.String (IsString(fromString)) import GHC.TypeLits (symbolVal, KnownSymbol) import Data.Proxy (Proxy(Proxy)) @@ -37,7 +35,6 @@ 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) @@ -46,14 +43,21 @@ import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as Map import Data.Ratio (Ratio) +import Data.Text (StrictText) +import Data.Bifunctor (Bifunctor(second)) +import qualified Data.Text.Lazy as LazyText type Indentation = Word -newtype Serializer a = Serializer (SerializerState -> (SerializerState, a)) +newtype Serializer a = Serializer (ContinuationSerializer a) deriving stock (Functor) +type ContinuationSerializer a = (SerializerState -> (SerializerState, a)) + +type Prepends = [StrictText] -> [StrictText] + data SerializerState = SerializerState - { builder :: !Builder + { builder :: Prepends , indentation :: !Indentation , increaseIndentation :: !(Indentation -> Indentation) , currentFieldIndex :: !(Maybe Word) @@ -63,16 +67,15 @@ instance Applicative Serializer where pure :: a -> Serializer a pure x = Serializer (, x) (<*>) :: Serializer (a -> b) -> Serializer a -> Serializer b - (<*>) (Serializer computeF) (Serializer computeX) = Serializer $ \ state -> let - (state', f) = computeF state - (state'', x) = computeX state' - in (state'', f x) + (<*>) (Serializer computeF) (Serializer computeA) = Serializer $ \ state -> let + (state', f) = computeF state + in second f $ computeA state' instance Monad Serializer where (>>=) :: Serializer a -> (a -> Serializer b) -> Serializer b (>>=) (Serializer computeA) f = Serializer $ \ state -> let (state', a) = computeA state - (Serializer computeB) = f a + (Serializer computeB) = f a in computeB state' getSerializerState :: Serializer SerializerState @@ -86,14 +89,14 @@ modifySerializerState f = getSerializerState >>= setSerializerState . f -- | Append a text to the serializer buffer. Does not check whether the emitted text contains a newline. -emit :: Text -> Serializer () -emit t = Serializer $ \ state -> (state { builder = state.builder <> Builder.fromLazyText t }, ()) +emit :: StrictText -> Serializer () +emit t = Serializer $ \ state -> (state { builder = \ suffix -> t : state.builder suffix }, ()) lineBreak :: Serializer () lineBreak = do spaces <- indentation <$!> getSerializerState emit "\n" - emit $ Text.replicate (fromIntegral spaces) " " + emit $ StrictText.replicate (fromIntegral spaces) " " recordField :: (Word -> Serializer ()) -> Serializer b -> Serializer b recordField labelField dumpField = do @@ -121,7 +124,7 @@ recordField labelField dumpField = do unnamedField :: Serializer a -> Serializer a unnamedField = recordField serializer -namedField :: Text -> Serializer a -> Serializer a +namedField :: StrictText -> Serializer a -> Serializer a namedField name = recordField (const $ emit name) customField :: Serializer () -> Serializer a -> Serializer a @@ -148,11 +151,11 @@ beginFields name body = do pure result -inNamedConstructor :: Text -> Serializer a -> Serializer a +inNamedConstructor :: StrictText -> Serializer a -> Serializer a inNamedConstructor name = beginFields $ Just (emit "::" >> emit name) -inDatatype :: Text -> Serializer b -> Serializer b +inDatatype :: StrictText -> Serializer b -> Serializer b inDatatype name body = do emit name @@ -160,14 +163,17 @@ inDatatype name body = do inDatatypeOf :: Typeable a => a -> Serializer b -> Serializer b inDatatypeOf x s = let - !typeName = Text.pack . show . typeOf $ x + !typeName = StrictText.pack . show . typeOf $ x in inDatatype typeName s -run :: Serializer () -> Text -run (Serializer computeUnit) = Builder.toLazyText . builder . fst . computeUnit $ SerializerState {builder=mempty, indentation=0, increaseIndentation=(+4), currentFieldIndex=Nothing} +run :: Serializer () -> LazyText +run (Serializer computeUnit) = let + initialState = SerializerState {builder=mempty, indentation=0, increaseIndentation=(+4), currentFieldIndex=Nothing} + endState = fst (computeUnit initialState) + in LazyText.fromChunks $ endState.builder [] class PrettySerialize a where - serialize :: a -> Text + serialize :: a -> LazyText serialize = run . serializer serializer :: a -> Serializer () @@ -196,9 +202,9 @@ deriving via ShowPrettySerialize Natural instance PrettySerialize Natural deriving via ShowPrettySerialize (Ratio a) instance Show a => PrettySerialize (Ratio a) -- text -deriving via ShowPrettySerialize Text instance PrettySerialize Text +deriving via ShowPrettySerialize LazyText instance PrettySerialize LazyText deriving via ShowPrettySerialize ByteString instance PrettySerialize ByteString -deriving via ShowPrettySerialize Strict.Text instance PrettySerialize Strict.Text +deriving via ShowPrettySerialize StrictText instance PrettySerialize StrictText deriving via ShowPrettySerialize LazyByteString instance PrettySerialize LazyByteString -- tuples