diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,117 @@ +This library (bytestring-show) contains some code adapted from other works. + + * Printing of various primitive values is adapted largely from the base + libraries distributed with GHC. The GHC license will be reproduced + below. + + * Decoding of characters into Word8s according to UTF-8 was + borrowed from utf8-string, which is (c) Eric Mertens. + + * Significant modifications and original code have been written by + Dan Doel. + +All code is aviailable under a BSD-style or compatibile license: + +---------------------------------------------------------------------------- + +Copyright (c) 2008 Dan Doel + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + +---------------------------------------------------------------------------- + +The original text of the GHC license is as follows: + +---------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +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 name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE 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 +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- + +Code derived from the document "The Haskell 98 Foreign Function +Interface, An Addendum to the Haskell 98 Report" is distributed under +the following license: + + Copyright (c) 2002 Manuel M. T. Chakravarty + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Foreign Function Interface. + +----------------------------------------------------------------------------- diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> import System.Cmd (system) + +> main = defaultMainWithHooks (defaultUserHooks { runTests = tests }) + +> tests _ _ _ _ = system "runhaskell Tests/Properties.hs" >> return () diff --git a/Tests/Properties.hs b/Tests/Properties.hs new file mode 100644 --- /dev/null +++ b/Tests/Properties.hs @@ -0,0 +1,36 @@ + +module Main where + +import Test.QuickCheck + +import Data.Complex +import Data.Int +import Data.Word +import Data.Ratio + +import qualified Text.Show.ByteString as S + +import qualified Data.ByteString.Lazy.Char8 as L + +test_matchesShow :: (Show a, S.Show a, Arbitrary a) => a -> Bool +test_matchesShow a = show a == L.unpack (S.show a) + +test_all :: IO () +test_all = do quickCheck (test_matchesShow :: Int -> Bool) +-- quickCheck (test_matchesShow :: Int8 -> Bool) +-- quickCheck (test_matchesShow :: Int16 -> Bool) +-- quickCheck (test_matchesShow :: Int32 -> Bool) +-- quickCheck (test_matchesShow :: Word -> Bool) +-- quickCheck (test_matchesShow :: Word8 -> Bool) +-- quickCheck (test_matchesShow :: Word16 -> Bool) +-- quickCheck (test_matchesShow :: Word32 -> Bool) + quickCheck (test_matchesShow :: () -> Bool) + quickCheck (test_matchesShow :: Integer -> Bool) + quickCheck (test_matchesShow :: Float -> Bool) + quickCheck (test_matchesShow :: Double -> Bool) + quickCheck (test_matchesShow :: Rational -> Bool) + quickCheck (test_matchesShow :: (Int,Int,Int) -> Bool) + quickCheck (test_matchesShow :: (Int,Int,Int,Int) -> Bool) + quickCheck (test_matchesShow :: [Int] -> Bool) + +main = test_all diff --git a/Text/Show/ByteString.hs b/Text/Show/ByteString.hs new file mode 100644 --- /dev/null +++ b/Text/Show/ByteString.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE TypeSynonymInstances #-} + +-- --------------------------------------------------------------------------- +-- | +-- Module : Text.Show.ByteString +-- Copyright : (c) 2008 Dan Doel +-- Maintainer : Dan Doel +-- Stability : Experimental +-- Portability : Non-portable (type synonym instances) +-- +-- Efficiently convert from values to lazy byte strings. + +module Text.Show.ByteString ( -- * The Show class + Show (..) + , show + -- * Putting Chars + , putAscii + , putUTF8 + -- * Putting Strings + , putAsciiStr + , putUTF8Str + -- * Putting digits + , unsafePutDigit + , putDigit + -- * Putting floats + , showpGFloat + , showpFFloat + , showpEFloat + -- * Combining builders + , unlinesP + , unwordsP + -- * Printing values + , print + ) where + +import Prelude hiding (Show(..), print, putStrLn) +import qualified Prelude + +import Data.Binary.Put +import Data.ByteString.Lazy + +import Data.Int +import Data.Word +import Data.Ratio +import Data.Complex + +import Text.Show.ByteString.Util ( putAscii , putUTF8 + , putAsciiStr, putUTF8Str + , unsafePutDigit + ) + +import Text.Show.ByteString.Char +import Text.Show.ByteString.Int +import Text.Show.ByteString.Integer +import Text.Show.ByteString.Float + +-- | Conversion of values to readable byte strings. +-- Minimal complete definition: 'showp' +class Show a where + -- | Encodes a value to an efficient byte string builder. + -- Values of type Put can be efficiently combined, so this + -- is available for building strings from multiple values. + showp :: a -> Put + + -- | Allows for specialized display of lists of values. + -- This is used, for example, when showing arrays of Chars. + showpList :: [a] -> Put + + showpList [] = putWord8 91 >> putWord8 93 -- "[]" + showpList (x:xs) = putWord8 91 >> showp x >> go xs -- "[.. + where + go (y:ys) = putWord8 44 >> showp y >> go ys -- ..,.. + go [ ] = putWord8 93 -- ..]" + +-- | Encode a single value into a byte string +show :: Show a => a -> ByteString +show = runPut . showp + +-- | Print a value to the standard output +print :: Show a => a -> IO () +print = putStrLn . show + +-- | Merge several string builders, separating them by newlines +unlinesP :: [Put] -> Put +unlinesP [ ] = return () +unlinesP (p:ps) = p >> putAscii '\n' >> unlinesP ps + +-- | Merge several string builders, separating them by spaces +unwordsP :: [Put] -> Put +unwordsP [ ] = return () +unwordsP [p] = p +unwordsP (p:ps) = p >> putAscii ' ' >> unwordsP ps + +-- | Puts the digit corresponding to the Int passed in. +putDigit :: Int -> Put +putDigit i + | i < 0 = error $ "putDigit: Negative integer: " ++ Prelude.show i + | i > 9 = error $ "putDigit: Non-decimal digit: " ++ Prelude.show i + | otherwise = unsafePutDigit i + +-- This may be a bad idea, but I'm trying it out +instance Show Put where + showp p = p + +instance Show () where + showp () = putAscii '(' >> putAscii ')' + +instance Show Char where + showp = showpChar + showpList = showpString + +instance Show Bool where + showp True = putAsciiStr "True" + showp False = putAsciiStr "False" + +instance (Show a) => Show [a] where + showp = showpList + +instance Show Int where + showp = showpInt + +instance Show Int8 where + showp = showpInt8 + +instance Show Int16 where + showp = showpInt16 + +instance Show Int32 where + showp = showpInt32 + +instance Show Word where + showp = showpWord + +instance Show Word8 where + showp = showpWord8 + +instance Show Word16 where + showp = showpWord16 + +instance Show Word32 where + showp = showpWord32 + +instance Show Integer where + showp = showpInteger + +instance Show Float where + showp = showpGFloat Nothing + +instance Show Double where + showp = showpGFloat Nothing + +instance (Show a, Integral a) => Show (Ratio a) where + showp q = wrap (numerator q) >> + putAscii '%' >> + showp (denominator q) + where + wrap n + | n < 0 = putAscii '(' >> showp n >> putAscii ')' + | otherwise = showp n + +instance (Show a, RealFloat a) => Show (Complex a) where + showp (a :+ b) = showp a >> + putAscii ' ' >> putAscii ':' >> putAscii '+' >> putAscii ' ' >> + showp b + +instance Show a => Show (Maybe a) where + showp Nothing = putAsciiStr "Nothing" + showp (Just a) = putAsciiStr "Just " >> showp a + +instance (Show a, Show b) => Show (a,b) where + showp (a,b) = putAscii '(' >> showp a >> putAscii ',' >> showp b >> putAscii ')' + +instance (Show a, Show b, Show c) => Show (a,b,c) where + showp (a,b,c) = putAscii '(' >> showp a >> + putAscii ',' >> showp b >> + putAscii ',' >> showp c >> + putAscii ')' + +instance (Show a, Show b, Show c, Show d) => Show (a,b,c,d) where + showp (a,b,c,d) = + putAscii '(' >> showp a >> + putAscii ',' >> showp b >> + putAscii ',' >> showp c >> + putAscii ',' >> showp d >> + putAscii ')' + +instance (Show a, Show b, Show c, Show d, Show e) => Show (a,b,c,d,e) where + showp (a,b,c,d,e) = + putAscii '(' >> showp a >> + putAscii ',' >> showp b >> + putAscii ',' >> showp c >> + putAscii ',' >> showp d >> + putAscii ',' >> showp e >> + putAscii ')' + +instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a,b,c,d,e,f) where + showp (a,b,c,d,e,f) = + putAscii '(' >> showp a >> + putAscii ',' >> showp b >> + putAscii ',' >> showp c >> + putAscii ',' >> showp d >> + putAscii ',' >> showp e >> + putAscii ',' >> showp f >> + putAscii ')' + +instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g) => Show (a,b,c,d,e,f,g) where + showp (a,b,c,d,e,f,g) = + putAscii '(' >> showp a >> + putAscii ',' >> showp b >> + putAscii ',' >> showp c >> + putAscii ',' >> showp d >> + putAscii ',' >> showp e >> + putAscii ',' >> showp f >> + putAscii ',' >> showp g >> + putAscii ')' diff --git a/Text/Show/ByteString/Char.hs b/Text/Show/ByteString/Char.hs new file mode 100644 --- /dev/null +++ b/Text/Show/ByteString/Char.hs @@ -0,0 +1,51 @@ +-- --------------------------------------------------------------------------- +-- | +-- Module : Text.Show.ByteString.Char +-- Copyright : (c) 2008 Dan Doel +-- Maintainer : Dan Doel +-- Stability : Experimental +-- Portability : Portable +-- +-- Putting characters. +-- +-- Functions based on GHC.Show in base + +module Text.Show.ByteString.Char where + +import Data.Binary +import Data.Char + +import Text.Show.ByteString.Util + +asciiTab :: [String] +asciiTab = ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", + "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", + "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", + "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", "SP"] + +putLitChar :: Char -> Put +putLitChar '\DEL' = putAsciiStr "\\DEL" +putLitChar '\\' = putAscii '\\' >> putAscii '\\' +putLitChar c | c >= ' ' = putUTF8 c +putLitChar '\a' = putAscii '\\' >> putAscii 'a' +putLitChar '\b' = putAscii '\\' >> putAscii 'b' +putLitChar '\f' = putAscii '\\' >> putAscii 'f' +putLitChar '\n' = putAscii '\\' >> putAscii 'n' +putLitChar '\r' = putAscii '\\' >> putAscii 'r' +putLitChar '\t' = putAscii '\\' >> putAscii 't' +putLitChar '\v' = putAscii '\\' >> putAscii 'v' +putLitChar '\SO' = putAscii '\\' >> putAscii 'S' >> putAscii 'O' +putLitChar c = putAscii '\\' >> putAsciiStr (asciiTab !! ord c) + +showpChar :: Char -> Put +showpChar c = putAscii '\'' >> putEscaped c >> putAscii '\'' + where + putEscaped '\'' = putAscii '\\' >> putAscii '\'' + putEscaped c' = putLitChar c' + +showpString :: String -> Put +showpString xs = putAscii '"' >> mapM_ putEscaped xs >> putAscii '"' + where + putEscaped '"' = putAscii '\\' >> putAscii '"' + putEscaped '\SO' = putAsciiStr "\\SO\\&" + putEscaped c = putLitChar c diff --git a/Text/Show/ByteString/Float.hs b/Text/Show/ByteString/Float.hs new file mode 100644 --- /dev/null +++ b/Text/Show/ByteString/Float.hs @@ -0,0 +1,91 @@ +-- --------------------------------------------------------------------------- +-- | +-- Module : Text.Show.ByteString.Float +-- Copyright : (c) 2008 Dan Doel +-- Maintainer : Dan Doel +-- Stability : Experimental +-- Portability : Non-portable (magic hash) +-- +-- Putting floating point values. +-- +-- The code in this module is heavily based on GHC.Float + +module Text.Show.ByteString.Float where + +import GHC.Float + +import Control.Monad + +import Data.Binary + +import Text.Show.ByteString.Util +import Text.Show.ByteString.Int + +-- | Show a signed RealFloat value using decimal notation when the +-- absolute value lies between 0.1 and 9,999,999, and scientific +-- notation otherwise. The optional integer can be used to specify +-- precision. +showpGFloat :: RealFloat a => Maybe Int -> a -> Put +showpGFloat = putFormattedFloat FFGeneric + +-- | Show a signed RealFloat value using decimal notation. The optional +-- integer can be used to specify precision. +showpFFloat :: RealFloat a => Maybe Int -> a -> Put +showpFFloat = putFormattedFloat FFFixed + +-- | Show a signed RealFloat value using scientific (exponential) notation. +-- The optional integer can be used to specify precision. +showpEFloat :: RealFloat a => Maybe Int -> a -> Put +showpEFloat = putFormattedFloat FFExponent + +putFormattedFloat :: RealFloat a => FFFormat -> Maybe Int -> a -> Put +putFormattedFloat fmt decs f + | isNaN f = putAscii 'N' >> putAscii 'a' >> putAscii 'N' + | isInfinite f = putAsciiStr (if f < 0 then "-Infinity" else "Infinity") + | f < 0 || isNegativeZero f = putAscii '-' >> go fmt (floatToDigits (toInteger base) (-f)) + | otherwise = go fmt (floatToDigits (toInteger base) f) + where + base = 10 + + go FFGeneric p@(_,e) + | e < 0 || e > 7 = go FFExponent p + | otherwise = go FFFixed p + go FFExponent (is, e) = + case decs of + Nothing -> case is of + [] -> error "putFormattedFloat" + [0] -> putAsciiStr "0.0e0" + [d] -> unsafePutDigit d >> putAsciiStr ".0e" >> showpInt e + (d:ds) -> unsafePutDigit d >> putAscii '.' >> mapM_ unsafePutDigit ds + >> putAscii 'e' >> showpInt (e-1) + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> putAscii '0' >> putAscii '.' >> replicateM_ dec' (putAscii '0') + >> putAscii 'e' >> putAscii '0' + _ -> + let (ei, is') = roundTo base (dec'+1) is + (d:ds) = if ei > 0 then init is' else is' + in unsafePutDigit d >> putAscii '.' >> mapM_ unsafePutDigit ds + >> putAscii 'e' >> showpInt (e - 1 + ei) + go FFFixed (is, e) = case decs of + Nothing + | e <= 0 -> putAscii '0' >> putAscii '.' >> replicateM_ (-e) (putAscii '0') + >> mapM_ unsafePutDigit is + | otherwise -> let g 0 rs = putAscii '.' >> mk0 rs + g n [] = putAscii '0' >> g (n-1) [] + g n (r:rs) = unsafePutDigit r >> g (n-1) rs + in g e is + Just dec -> + let dec' = max dec 0 in + if e >= 0 then + let (ei, is') = roundTo base (dec' + e) is + (ls,rs) = splitAt (e+ei) is' + in mk0 ls >> when (not $ null rs) (putAscii '.' >> mapM_ unsafePutDigit rs) + else + let (ei, is') = roundTo base dec' (replicate (-e) 0 ++ is) + d:ds = if ei > 0 then is' else 0:is' + in unsafePutDigit d >> when (not $ null ds) (putAscii '.' >> mapM_ unsafePutDigit ds) + + mk0 [] = putAscii '0' + mk0 rs = mapM_ unsafePutDigit rs diff --git a/Text/Show/ByteString/Int.hs b/Text/Show/ByteString/Int.hs new file mode 100644 --- /dev/null +++ b/Text/Show/ByteString/Int.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE MagicHash #-} + +-- --------------------------------------------------------------------------- +-- | +-- Module : Text.Show.ByteString.Int +-- Copyright : (c) 2008 Dan Doel +-- Maintainer : Dan Doel +-- Stability : Experimental +-- Portability : Non-portable (magic hash) +-- +-- Putting integers and words. +-- +-- The code in this module is based on the printing in the GHC modules. + +module Text.Show.ByteString.Int where + +import GHC.Base +import GHC.Int +import GHC.Word + +import Data.Binary + +import Text.Show.ByteString.Util + +putI :: Int# -> Put +putI i# + | i# <# 0# = let I# minInt# = minInt + in if i# ==# minInt# + then putWord8 45 >> putW (int2Word# (negateInt# (i# `quotInt#` 10#))) + >> putW (int2Word# (negateInt# (i# `remInt#` 10#))) + else putWord8 45 >> putW (int2Word# (negateInt# i#)) + | otherwise = putW (int2Word# i#) + +putW :: Word# -> Put +putW w# + | w# `ltWord#` int2Word# 10# = unsafePutDigit# w# + | otherwise = putW (w# `quotWord#` int2Word# 10#) + >> unsafePutDigit# (w# `remWord#` int2Word# 10#) + +showpInt :: Int -> Put +showpInt (I# i#) = putI i# + +showpInt8 :: Int8 -> Put +showpInt8 (I8# i#) = putI i# + +showpInt16 :: Int16 -> Put +showpInt16 (I16# i#) = putI i# + +showpInt32 :: Int32 -> Put +showpInt32 (I32# i#) = putI i# + +showpWord :: Word -> Put +showpWord (W# w#) = putW w# + +showpWord8 :: Word8 -> Put +showpWord8 (W8# w#) = putW w# + +showpWord16 :: Word16 -> Put +showpWord16 (W16# w#) = putW w# + +showpWord32 :: Word32 -> Put +showpWord32 (W32# w#) = putW w# diff --git a/Text/Show/ByteString/Integer.hs b/Text/Show/ByteString/Integer.hs new file mode 100644 --- /dev/null +++ b/Text/Show/ByteString/Integer.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} + +-- --------------------------------------------------------------------------- +-- | +-- Module : Text.Show.ByteString.Integer +-- Copyright : (c) 2008 Dan Doel +-- Maintainer : Dan Doel +-- Stability : Experimental +-- Portability : Non-portable (magic hash, bang patterns) +-- +-- Putting unbounded integers. +-- +-- This code is based off the integer showing code in GHC. + +module Text.Show.ByteString.Integer where + +import GHC.Base +import GHC.Num + +import Data.Binary.Put + +import Text.Show.ByteString.Util +import Text.Show.ByteString.Int + +mx :: Integer +ds :: Int +(mx, ds) = until ((>mi) . (*10) . fst) (\(n,d) -> (n*10,d+1)) (10,1) + where mi = fromIntegral (maxBound :: Int) + +showpInteger :: Integer -> Put +showpInteger (S# i#) = putI i# +showpInteger n + | n < 0 = putAscii '-' >> posIntegerPut (-n) + | otherwise = posIntegerPut n + +posIntegerPut :: Integer -> Put +posIntegerPut n + | n < mx = case fromInteger n of + I# i# -> putI i# + | otherwise = printh (splitf (mx*mx) n) + +splitf :: Integer -> Integer -> [Integer] +splitf p n + | p > n = [n] + | otherwise = splith p (splitf (p*p) n) + +splith :: Integer -> [Integer] -> [Integer] +splith _ [ ] = error "splith: the impossible happened." +splith p (n:ns) = case n `quotRemInteger` p of + (q, r) -> if q > 0 + then q : r : splitb p ns + else r : splitb p ns + +splitb :: Integer -> [Integer] -> [Integer] +splitb _ [ ] = [] +splitb p (n:ns) = case n `quotRemInteger` p of + (q, r) -> q : r : splitb p ns + +printh :: [Integer] -> Put +printh [ ] = error "printh: the impossible happened." +printh (n:ns) = case n `quotRemInteger` mx of + (q', r') -> let q = fromInteger q' + r = fromInteger r' + in if q > 0 then phead q >> pblock r >> printb ns + else phead r >> printb ns + +printb :: [Integer] -> Put +printb [ ] = return () +printb (n:ns) = case n `quotRemInteger` mx of + (q', r') -> let q = fromInteger q' + r = fromInteger r' + in pblock q >> pblock r >> printb ns + +phead :: Int -> Put +phead (I# i#) = putI i# + +pblock :: Int -> Put +pblock = pblock' ds + +pblock' :: Int -> Int -> Put +pblock' d !n + | d == 1 = unsafePutDigit n + | otherwise = pblock' (d-1) q >> unsafePutDigit r + where (q, r) = n `quotRemInt` 10 diff --git a/Text/Show/ByteString/Util.hs b/Text/Show/ByteString/Util.hs new file mode 100644 --- /dev/null +++ b/Text/Show/ByteString/Util.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE MagicHash #-} + +-- --------------------------------------------------------------------------- +-- | +-- Module : Text.Show.ByteString.Util +-- Copyright : (c) 2008 Dan Doel +-- Maintainer : Dan Doel +-- Stability : Experimental +-- Portability : Non-portable (magic hash, GHC libraries) +-- +-- Utility functions for producing readable byte strings. + +module Text.Show.ByteString.Util ( putAscii + , putUTF8 + , putAsciiStr + , putUTF8Str + , unsafePutDigit + , unsafePutDigit# + ) where + +import GHC.Base +import GHC.Word + +import Data.Binary +import Data.Bits + +import Data.ByteString.Internal (c2w) + +-- | Writes a single Char to a byte string, assuming it's ascii. +putAscii :: Char -> Put +putAscii = putWord8 . c2w + +-- | Writes a single Char to a byte string, properly UTF-8 encoded +putUTF8 :: Char -> Put +putUTF8 c + | oc <= 0x7f = putWord8 (fromIntegral oc) + | oc <= 0x7ff = do putWord8 . fromIntegral $ 0xc0 + (oc `shiftR` 6) + putWord8 . fromIntegral $ 0x80 + oc .&. 0x3f + | oc <= 0xffff = do putWord8 . fromIntegral $ 0xf0 + (oc `shiftR` 12) + putWord8 . fromIntegral $ 0x80 + ((oc `shiftR` 6) .&. 0x3f) + putWord8 . fromIntegral $ 0x80 + oc .&. 0x3f + | otherwise = do putWord8 . fromIntegral $ 0xf0 + (oc `shiftR` 18) + putWord8 . fromIntegral $ 0x80 + ((oc `shiftR` 12) .&. 0x3f) + putWord8 . fromIntegral $ 0x80 + ((oc `shiftR` 6) .&. 0x3f) + putWord8 . fromIntegral $ 0x80 + oc .&. 0x3f + where + oc = ord c + +-- | Writes a string of ascii characters to a byte string +putAsciiStr :: String -> Put +putAsciiStr = mapM_ putAscii + +-- | Writes a string of unicode characters to a byte string, +-- properly UTF-8 encoded +putUTF8Str :: String -> Put +putUTF8Str = mapM_ putUTF8 + +-- | Puts the decimal digit corresponding to the given Int without +-- checking that it is in the interval [0,9] +unsafePutDigit :: Int -> Put +unsafePutDigit (I# i#) = unsafePutDigit# (int2Word# i#) + +unsafePutDigit# :: Word# -> Put +unsafePutDigit# w# = putWord8 (W8# (w# `plusWord#` int2Word# 48#)) diff --git a/bytestring-show.cabal b/bytestring-show.cabal new file mode 100644 --- /dev/null +++ b/bytestring-show.cabal @@ -0,0 +1,31 @@ +Name: bytestring-show +Version: 0.1 +License: BSD3 +License-File: LICENSE +Author: Dan Doel +Maintainer: Dan Doel +Homepage: http://code.haskell.org/~dolio/ +Category: Text +Synopsis: Efficient conversion of values into readable byte strings. +Description: Efficient conversion of values into readable byte strings. +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Build-Depends: base, binary, bytestring >= 0.9, QuickCheck + + Exposed-Modules: + Text.Show.ByteString + + Other-Modules: + Text.Show.ByteString.Util + Text.Show.ByteString.Char + Text.Show.ByteString.Int + Text.Show.ByteString.Float + Text.Show.ByteString.Integer + + Extensions: + MagicHash, BangPatterns, TypeSynonymInstances + + GHC-Options: + -O2 -Wall