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