feat: rewrite to continuation style

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 (LazyText)
-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 ((<$!>), 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
+  (<*>) (Serializer computeF) (Serializer computeA) = Serializer $ \ state -> let
-    (state', f)  = computeF state
+    (state', f) = computeF state
-    (state'', x) = computeX state'
+    in second f $ computeA state'
-    in (state'', f x)
 
 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 :: StrictText -> Serializer ()
-emit t = Serializer $ \ state -> (state { builder = state.builder <> Builder.fromLazyText t }, ())
+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 () -> LazyText
-run (Serializer computeUnit) = Builder.toLazyText . builder . fst . computeUnit $ SerializerState {builder=mempty, indentation=0, increaseIndentation=(+4), currentFieldIndex=Nothing}
+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