1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
-- |
-- Module : Basement.Block.Builder
-- License : BSD-style
-- Maintainer : Foundation
--
-- Block builder
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeOperators #-}
module Basement.Block.Builder
( Builder
, run
-- * Emit functions
, emit
, emitPrim
, emitString
, emitUTF8Char
-- * unsafe
, unsafeRunString
) where
import qualified Basement.Alg.UTF8 as UTF8
import Basement.UTF8.Helper (charToBytes)
import Basement.Numerical.Conversion (charToInt)
import Basement.Block.Base (Block(..), MutableBlock(..))
import qualified Basement.Block.Base as B
import Basement.Cast
import Basement.Compat.Base
import Basement.Compat.Semigroup
import Basement.Monad
import Basement.FinalPtr (FinalPtr, withFinalPtr)
import Basement.Numerical.Additive
import Basement.String (String(..))
import qualified Basement.String as S
import Basement.Types.OffsetSize
import Basement.PrimType (PrimType(..), primMbaWrite)
import Basement.UArray.Base (UArray(..))
import qualified Basement.UArray.Base as A
import GHC.ST
import Data.Proxy
newtype Action = Action
{ runAction_ :: forall prim . PrimMonad prim
=> MutableBlock Word8 (PrimState prim)
-> Offset Word8
-> prim (Offset Word8)
}
data Builder = Builder {-# UNPACK #-} !(CountOf Word8)
!Action
instance Semigroup Builder where
(<>) = append
{-# INLINABLE (<>) #-}
instance Monoid Builder where
mempty = empty
{-# INLINABLE mempty #-}
mconcat = concat
{-# INLINABLE mconcat #-}
-- | create an empty builder
--
-- this does nothing, build nothing, take no space (in the resulted block)
empty :: Builder
empty = Builder 0 (Action $ \_ !off -> pure off)
{-# INLINE empty #-}
-- | concatenate the 2 given bulider
append :: Builder -> Builder -> Builder
append (Builder size1 (Action action1)) (Builder size2 (Action action2)) =
Builder size action
where
action = Action $ \arr off -> do
off' <- action1 arr off
action2 arr off'
size = size1 + size2
{-# INLINABLE append #-}
-- | concatenate the list of builder
concat :: [Builder] -> Builder
concat = loop 0 (Action $ \_ !off -> pure off)
where
loop !sz acc [] = Builder sz acc
loop !sz (Action acc) (Builder !s (Action action):xs) =
loop (sz + s) (Action $ \arr off -> acc arr off >>= action arr) xs
{-# INLINABLE concat #-}
-- | run the given builder and return the generated block
run :: PrimMonad prim => Builder -> prim (Block Word8)
run (Builder sz action) = do
mb <- B.new sz
off <- runAction_ action mb 0
B.unsafeShrink mb (offsetAsSize off) >>= B.unsafeFreeze
-- | run the given builder and return a UTF8String
--
-- this action is unsafe as there is no guarantee upon the validity of the
-- content of the built block.
unsafeRunString :: PrimMonad prim => Builder -> prim String
unsafeRunString b = do
str <- run b
pure $ String $ A.UArray 0 (B.length str) (A.UArrayBA str)
-- | add a Block in the builder
emit :: Block a -> Builder
emit b = Builder size $ Action $ \arr off ->
B.unsafeCopyBytesRO arr off b' 0 size *> pure (off + sizeAsOffset size)
where
b' :: Block Word8
b' = cast b
size :: CountOf Word8
size = B.length b'
emitPrim :: (PrimType ty, ty ~ Word8) => ty -> Builder
emitPrim a = Builder size $ Action $ \(MutableBlock arr) off ->
primMbaWrite arr off a *> pure (off + sizeAsOffset size)
where
size = getSize Proxy a
getSize :: PrimType ty => Proxy ty -> ty -> CountOf Word8
getSize p _ = primSizeInBytes p
-- | add a string in the builder
emitString :: String -> Builder
emitString (String str) = Builder size $ Action $ \arr off ->
A.onBackendPrim (onBA arr off) (onAddr arr off) str *> pure (off + sizeAsOffset size)
where
size = A.length str
onBA :: PrimMonad prim
=> MutableBlock Word8 (PrimState prim)
-> Offset Word8
-> Block Word8
-> prim ()
onBA arr off ba = B.unsafeCopyBytesRO arr off ba 0 size
onAddr :: PrimMonad prim
=> MutableBlock Word8 (PrimState prim)
-> Offset Word8
-> FinalPtr Word8
-> prim ()
onAddr arr off fptr = withFinalPtr fptr $ \ptr -> B.unsafeCopyBytesPtr arr off ptr size
-- | emit a UTF8 char in the builder
--
-- this function may be replaced by `emit :: Encoding -> Char -> Builder`
emitUTF8Char :: Char -> Builder
emitUTF8Char c = Builder (charToBytes $ charToInt c) $ Action $ \block@(MutableBlock !_) off ->
UTF8.writeUTF8 block off c
|
