Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Clean repo with builder code

  • Loading branch information...
commit 9e8def76be0a7bfb3199c684d467c557e4652e4f 1 parent e89e84f
@jaspervdj jaspervdj authored
View
1  .gitignore
@@ -0,0 +1 @@
+dist
View
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright Jasper Van der Jeugt 2010
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Jasper Van der Jeugt nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
View
202 Text/Blaze/Builder/Core.hs
@@ -0,0 +1,202 @@
+-- | The builder monoid from BlazeHtml.
+--
+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
+module Text.Blaze.Builder.Core
+ (
+ -- * Main builder type
+ Builder
+
+ -- * Custom writes to the builder
+ , Write (..)
+ , writeByte
+ , writeByteString
+ , writeSingleton
+ , writeList
+
+ -- * Creating builders
+ , singleton
+ , copyByteString
+
+ -- * Extracting the result from a builder
+ , toLazyByteString
+ ) where
+
+import Foreign
+import Data.Monoid (Monoid, mempty, mappend, mconcat)
+import qualified Data.ByteString.Char8 ()
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Internal as S
+import qualified Data.ByteString.Lazy as L
+
+-- | Main builder type. It simply contains a function to extract the actual
+-- data.
+--
+newtype Builder = Builder (BuildStep -> BuildStep)
+
+-- | A buildsignal is a signal returned from a write to the builder, it tells us
+-- what should happen next.
+--
+data BuildSignal
+ -- | Signal the completion of the write process.
+ = Done {-# UNPACK #-} !(Ptr Word8) -- ^ Pointer to the next free byte
+ -- | Signal that the buffer is full and a new one needs to be allocated.
+ -- It contains the minimal size required for the next buffer, a pointer to the
+ -- next free byte, and a continuation.
+ | BufferFull
+ {-# UNPACK #-} !Int
+ {-# UNPACK #-} !(Ptr Word8)
+ {-# UNPACK #-} !BuildStep
+
+-- | Type for a single build step. Every build step checks that
+--
+-- > free + bytes-written <= last
+--
+type BuildStep = Ptr Word8 -- ^ Ptr to the next free byte in the buffer
+ -> Ptr Word8 -- ^ Ptr to the first byte AFTER the buffer
+ -> IO BuildSignal -- ^ Signal the next step to be taken
+
+instance Monoid Builder where
+ mempty = Builder id
+ {-# INLINE mempty #-}
+ mappend (Builder f) (Builder g) = Builder $ f . g
+ {-# INLINE mappend #-}
+ mconcat = foldr mappend mempty
+ {-# INLINE mconcat #-}
+
+-- | Write abstraction so we can avoid some gory and bloody details. A write
+-- abstration holds the exact size of the write in bytes, and a function to
+-- carry out the write operation.
+--
+data Write = Write
+ {-# UNPACK #-} !Int
+ (Ptr Word8 -> IO ())
+
+-- A monoid interface for the write actions.
+instance Monoid Write where
+ mempty = Write 0 (const $ return ())
+ {-# INLINE mempty #-}
+ mappend (Write l1 f1) (Write l2 f2) = Write (l1 + l2) $ \ptr -> do
+ f1 ptr
+ f2 (ptr `plusPtr` l1)
+ {-# INLINE mappend #-}
+
+-- | Write a single byte.
+--
+writeByte :: Word8 -- ^ Byte to write
+ -> Write -- ^ Resulting write
+writeByte x = Write 1 (\pf -> poke pf x)
+{-# INLINE writeByte #-}
+
+-- | Write a strict 'S.ByteString'.
+--
+writeByteString :: S.ByteString -- ^ 'S.ByteString' to write
+ -> Write -- ^ Resulting write
+writeByteString bs = Write l io
+ where
+ (fptr, o, l) = S.toForeignPtr bs
+ io pf = withForeignPtr fptr $ \p -> copyBytes pf (p `plusPtr` o) l
+{-# INLINE writeByteString #-}
+
+-- | Construct a 'Builder' from a single 'Write' abstraction.
+--
+writeSingleton :: (a -> Write) -- ^ 'Write' abstraction
+ -> a -- ^ Actual value to write
+ -> Builder -- ^ Resulting 'Builder'
+writeSingleton write = makeBuilder
+ where
+ makeBuilder x = Builder step
+ where
+ step k pf pe
+ | pf `plusPtr` size <= pe = do
+ io pf
+ let pf' = pf `plusPtr` size
+ pf' `seq` k pf' pe
+ | otherwise = return $ BufferFull size pf (step k)
+ where
+ Write size io = write x
+{-# INLINE writeSingleton #-}
+
+-- | Construct a builder writing a list of data from a write abstraction.
+--
+writeList :: (a -> Write) -- ^ 'Write' abstraction
+ -> [a] -- ^ List of values to write
+ -> Builder -- ^ Resulting 'Builder'
+writeList write = makeBuilder
+ where
+ makeBuilder [] = mempty
+ makeBuilder xs0 = Builder $ step xs0
+ where
+ step xs1 k pf0 pe0 = go xs1 pf0
+ where
+ go [] !pf = k pf pe0
+ go xs@(x':xs') !pf
+ | pf `plusPtr` size <= pe0 = do
+ io pf
+ go xs' (pf `plusPtr` size)
+ | otherwise = do return $ BufferFull size pf (step xs k)
+ where
+ Write size io = write x'
+{-# INLINE writeList #-}
+
+-- | Construct a 'Builder' from a single byte.
+--
+singleton :: Word8 -- ^ Byte to create a 'Builder' from
+ -> Builder -- ^ Resulting 'Builder'
+singleton = writeSingleton writeByte
+
+-- | /O(n)./ A Builder taking a 'S.ByteString`, copying it.
+--
+copyByteString :: S.ByteString -- ^ Strict 'S.ByteString' to copy
+ -> Builder -- ^ Resulting 'Builder'
+copyByteString = writeSingleton writeByteString
+{-# INLINE copyByteString #-}
+
+-- | Copied from Data.ByteString.Lazy.
+--
+defaultSize :: Int
+defaultSize = 32 * k - overhead
+ where k = 1024
+ overhead = 2 * sizeOf (undefined :: Int)
+
+-- | Run the builder with the default buffer size.
+--
+runBuilder :: Builder -> [S.ByteString] -> [S.ByteString]
+runBuilder = runBuilderWith defaultSize
+{-# INLINE runBuilder #-}
+
+-- | Run the builder with buffers of at least the given size.
+--
+-- Note that the builders should guarantee that on average the desired buffer
+-- size is attained almost perfectly. "Almost" because builders may decide to
+-- start a new buffer and not completely fill the existing buffer, if this is
+-- faster. However, they should not spill too much of the buffer, if they
+-- cannot compensate for it.
+--
+runBuilderWith :: Int -> Builder -> [S.ByteString] -> [S.ByteString]
+runBuilderWith bufSize (Builder b) k =
+ S.inlinePerformIO $ go bufSize (b finalStep)
+ where
+ finalStep pf _ = return $ Done pf
+
+ go !size !step = do
+ buf <- S.mallocByteString size
+ withForeignPtr buf $ \pf -> do
+ next <- step pf (pf `plusPtr` size)
+ case next of
+ Done pf'
+ | pf == pf' -> return k
+ | otherwise -> return $ S.PS buf 0 (pf' `minusPtr` pf) : k
+ BufferFull newSize pf' nextStep
+ | pf == pf' -> bufferFullError
+ | otherwise -> return $ S.PS buf 0 (pf' `minusPtr` pf) :
+ S.inlinePerformIO (go (max newSize bufSize) nextStep)
+
+ bufferFullError =
+ error "runBuilder: buffer cannot be full; no data was written."
+
+-- | /O(n)./ Extract the lazy 'L.ByteString' from the builder.
+--
+toLazyByteString :: Builder -- ^ 'Builder' to evaluate
+ -> L.ByteString -- ^ Resulting UTF-8 encoded 'L.ByteString'
+toLazyByteString = L.fromChunks . flip runBuilder []
+{-# INLINE toLazyByteString #-}
View
55 Text/Blaze/Builder/Html.hs
@@ -0,0 +1,55 @@
+-- | A module that extends the builder monoid from BlazeHtml with function to
+-- insert HTML, including HTML escaping and the like.
+--
+{-# LANGUAGE OverloadedStrings #-}
+module Text.Blaze.Builder.Html
+ (
+ -- * Custom writes to the builder
+ writeHtmlEscapedChar
+
+ -- * Creating builders
+ , fromHtmlEscapedChar
+ , fromHtmlEscapedString
+ , fromHtmlEscapedText
+ ) where
+
+import Data.ByteString.Char8 ()
+import Data.Monoid (mempty, mappend)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Text.Blaze.Builder.Core
+import Text.Blaze.Builder.Utf8
+
+-- | Write an unicode character to a 'Builder', doing HTML escaping.
+--
+writeHtmlEscapedChar :: Char -- ^ Character to write
+ -> Write -- ^ Resulting write
+writeHtmlEscapedChar '<' = writeByteString "&lt;"
+writeHtmlEscapedChar '>' = writeByteString "&gt;"
+writeHtmlEscapedChar '&' = writeByteString "&amp;"
+writeHtmlEscapedChar '"' = writeByteString "&quot;"
+writeHtmlEscapedChar '\'' = writeByteString "&apos;"
+writeHtmlEscapedChar c = writeChar c
+{-# INLINE writeHtmlEscapedChar #-}
+
+-- | A HTML escaped 'Char'.
+--
+fromHtmlEscapedChar :: Char -- ^ Character to write
+ -> Builder -- ^ Resulting 'Builder'
+fromHtmlEscapedChar = writeSingleton writeHtmlEscapedChar
+
+-- | A HTML escaped 'String'.
+--
+fromHtmlEscapedString :: String -- ^ String to create a 'Builder' from
+ -> Builder -- ^ Resulting 'Builder'
+fromHtmlEscapedString = writeList writeHtmlEscapedChar
+
+-- | An HTML escaped piece of 'Text'.
+--
+fromHtmlEscapedText :: Text -- ^ 'Text' to insert
+ -> Builder -- ^ Resulting 'Builder'
+fromHtmlEscapedText = writeSingleton (T.foldl appendChar mempty)
+ where
+ appendChar w c = w `mappend` writeHtmlEscapedChar c
View
91 Text/Blaze/Builder/Utf8.hs
@@ -0,0 +1,91 @@
+-- | A module that extends the builder monoid from BlazeHtml with a number of
+-- functions to insert unicode as UTF-8.
+--
+module Text.Blaze.Builder.Utf8
+ (
+ -- * Custom writes to the builder
+ writeChar
+
+ -- * Creating builders
+ , fromChar
+ , fromString
+ , fromText
+ ) where
+
+import Foreign
+import Data.Char (ord)
+import Data.Monoid (mempty, mappend)
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Text.Blaze.Builder.Core
+
+-- | Write a Unicode character, encoding it as UTF-8.
+--
+writeChar :: Char -- ^ Character to write
+ -> Write -- ^ Resulting write
+writeChar = encodeCharUtf8 f1 f2 f3 f4
+ where
+ f1 x = Write 1 $ \ptr -> poke ptr x
+
+ f2 x1 x2 = Write 2 $ \ptr -> do poke ptr x1
+ poke (ptr `plusPtr` 1) x2
+
+ f3 x1 x2 x3 = Write 3 $ \ptr -> do poke ptr x1
+ poke (ptr `plusPtr` 1) x2
+ poke (ptr `plusPtr` 2) x3
+
+ f4 x1 x2 x3 x4 = Write 4 $ \ptr -> do poke ptr x1
+ poke (ptr `plusPtr` 1) x2
+ poke (ptr `plusPtr` 2) x3
+ poke (ptr `plusPtr` 3) x4
+{-# INLINE writeChar #-}
+
+-- | Encode a Unicode character to another datatype, using UTF-8. This function
+-- acts as an abstract way of encoding characters, as it is unaware of what
+-- needs to happen with the resulting bytes: you have to specify functions to
+-- deal with those.
+--
+encodeCharUtf8 :: (Word8 -> a) -- ^ 1-byte UTF-8
+ -> (Word8 -> Word8 -> a) -- ^ 2-byte UTF-8
+ -> (Word8 -> Word8 -> Word8 -> a) -- ^ 3-byte UTF-8
+ -> (Word8 -> Word8 -> Word8 -> Word8 -> a) -- ^ 4-byte UTF-8
+ -> Char -- ^ Input 'Char'
+ -> a -- ^ Result
+encodeCharUtf8 f1 f2 f3 f4 c = case ord c of
+ x | x <= 0x7F -> f1 $ fromIntegral x
+ | x <= 0x07FF ->
+ let x1 = fromIntegral $ (x `shiftR` 6) + 0xC0
+ x2 = fromIntegral $ (x .&. 0x3F) + 0x80
+ in f2 x1 x2
+ | x <= 0xFFFF ->
+ let x1 = fromIntegral $ (x `shiftR` 12) + 0xE0
+ x2 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80
+ x3 = fromIntegral $ (x .&. 0x3F) + 0x80
+ in f3 x1 x2 x3
+ | otherwise ->
+ let x1 = fromIntegral $ (x `shiftR` 18) + 0xF0
+ x2 = fromIntegral $ ((x `shiftR` 12) .&. 0x3F) + 0x80
+ x3 = fromIntegral $ ((x `shiftR` 6) .&. 0x3F) + 0x80
+ x4 = fromIntegral $ (x .&. 0x3F) + 0x80
+ in f4 x1 x2 x3 x4
+{-# INLINE encodeCharUtf8 #-}
+
+-- | An unescaped, utf8 encoded character.
+--
+fromChar :: Char -- ^ 'Char' to insert
+ -> Builder -- ^ Resulting 'Builder'
+fromChar = writeSingleton writeChar
+
+-- | A list of unescaped, utf8 encoded characters.
+--
+fromString :: String -- ^ 'String' to insert
+ -> Builder -- ^ Resulting 'Builder'
+fromString = writeList writeChar
+
+-- | Create an UTF-8 encoded 'Builder' from some 'Text'.
+--
+fromText :: Text -- ^ 'Text' to insert
+ -> Builder -- ^ Resulting 'Builder'
+fromText = writeSingleton (T.foldl (\w c -> w `mappend` writeChar c) mempty)
View
27 blaze-builder.cabal
@@ -0,0 +1,27 @@
+Name: blaze-builder
+Version: 0.2.0
+Synopsis: Builder to efficiently append text.
+Description: Builder to efficiently append text, optimized for
+ HTML generation.
+Homepage: http://jaspervdj.be/blaze
+Bug-Reports: http://github.com/jaspervdj/BlazeHtml/issues
+License: BSD3
+License-file: LICENSE
+Author: Jasper Van der Jeugt, Simon Meier
+Maintainer: jaspervdj@gmail.com, simon.meier@inf.ethz.ch
+Stability: Experimental
+Category: Text
+Build-type: Simple
+Cabal-version: >=1.2
+Library
+ Ghc-Options: -Wall
+
+ -- Modules exported by the library.
+ Exposed-modules: Text.Blaze.Builder.Core
+ Text.Blaze.Builder.Utf8
+ Text.Blaze.Builder.Html
+
+ -- Packages needed in order to build this package.
+ Build-depends: base >= 4 && < 5,
+ text >= 0.7,
+ bytestring >= 0.9
Please sign in to comment.
Something went wrong with that request. Please try again.