diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/Blaze/Builder/Core.hs b/Text/Blaze/Builder/Core.hs new file mode 100644 --- /dev/null +++ b/Text/Blaze/Builder/Core.hs @@ -0,0 +1,219 @@ +-- | The builder monoid from BlazeHtml. +-- +-- Usage is fairly straightforward. Builders can be constructed from many +-- values, including 'String' and 'Text' values. +-- +-- > strings :: [String] +-- > strings = replicate 10000 "Hello there!" +-- +-- Concatenation should happen through the 'Monoid' interface. +-- +-- > concatenation :: Builder +-- > concatenation = mconcat $ map fromString strings +-- +-- There is only one way to efficiently obtain the result: to convert the +-- 'Builder' to a lazy 'L.ByteString' using 'toLazyByteString'. +-- +-- > result :: L.ByteString +-- > result = toLazyByteString concatenation +-- +{-# 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 + , fromByteString + + -- * 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. +-- +fromByteString :: S.ByteString -- ^ Strict 'S.ByteString' to copy + -> Builder -- ^ Resulting 'Builder' +fromByteString = writeSingleton writeByteString +{-# INLINE fromByteString #-} + +-- | 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 #-} diff --git a/Text/Blaze/Builder/Html.hs b/Text/Blaze/Builder/Html.hs new file mode 100644 --- /dev/null +++ b/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 "<" +writeHtmlEscapedChar '>' = writeByteString ">" +writeHtmlEscapedChar '&' = writeByteString "&" +writeHtmlEscapedChar '"' = writeByteString """ +writeHtmlEscapedChar '\'' = writeByteString "'" +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 diff --git a/Text/Blaze/Builder/Utf8.hs b/Text/Blaze/Builder/Utf8.hs new file mode 100644 --- /dev/null +++ b/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) diff --git a/blaze-builder.cabal b/blaze-builder.cabal new file mode 100644 --- /dev/null +++ b/blaze-builder.cabal @@ -0,0 +1,29 @@ +Name: blaze-builder +Version: 0.1 +Synopsis: Builder to efficiently append text. +Description: Builder to efficiently append text, optimized for + HTML generation. There is a small usage example in the + Text.Blaze.Builder.Core module, you should begin by + reading that. +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