aboutsummaryrefslogtreecommitdiffhomepage
path: root/Pipes/Text/Internal.hs
blob: 7e5b04491dba0c7fa2638a400f5b34eb076e1057 (plain) (blame)
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
151
152
153
154
155
156
157
158
159
160
161
162
163
{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving, MagicHash,
    UnliftedFFITypes #-}
-- This module lifts assorted materials from Brian O'Sullivan's text package 
-- especially Data.Text.Encoding in order to define a pipes-appropriate
-- streamDecodeUtf8
module Pipes.Text.Internal 
    ( Decoding(..)
    , streamDecodeUtf8
    , decodeSomeUtf8
    ) where
import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
import Control.Monad.ST (ST, runST)
import Data.Bits ((.&.))
import Data.ByteString as B 
import Data.ByteString.Internal as B 
import qualified Data.Text as T (null)
import Data.Text.Encoding.Error ()
import Data.Text.Internal (Text, textP)
import Foreign.C.Types (CSize)
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr)
import Foreign.Storable (Storable, peek, poke)
import GHC.Base  (Char(..), Int(..), MutableByteArray#, ord#, iShiftRA#)
import GHC.Word (Word8, Word32)
import qualified Data.Text.Array as A
    
#include "pipes_text_cbits.h"

-- | A stream oriented decoding result.
data Decoding = Some Text ByteString (ByteString -> Decoding)
              | Other Text ByteString
instance Show Decoding where
    showsPrec d (Some t bs _) = showParen (d > prec) $
                                showString "Some " . showsPrec prec' t .
                                showChar ' ' . showsPrec prec' bs .
                                showString " _"
      where prec = 10; prec' = prec + 1
    showsPrec d (Other t bs)  = showParen (d > prec) $
                                showString "Other " . showsPrec prec' t .
                                showChar ' ' . showsPrec prec' bs .
                                showString " _"
      where prec = 10; prec' = prec + 1

newtype CodePoint = CodePoint Word32 deriving (Eq, Show, Num, Storable)
newtype DecoderState = DecoderState Word32 deriving (Eq, Show, Num, Storable)

streamDecodeUtf8 :: ByteString -> Decoding
streamDecodeUtf8 = decodeChunkUtf8 B.empty 0 0 
  where
  decodeChunkUtf8 :: ByteString -> CodePoint -> DecoderState -> ByteString -> Decoding
  decodeChunkUtf8 old codepoint0 state0 bs@(PS fp off len) = 
                    runST $ do marray <- A.new (len+1) 
                               unsafeIOToST (decodeChunkToBuffer marray)
     where
     decodeChunkToBuffer :: A.MArray s -> IO Decoding
     decodeChunkToBuffer dest = withForeignPtr fp $ \ptr ->
       with (0::CSize) $ \destOffPtr ->
       with codepoint0 $ \codepointPtr ->
       with state0     $ \statePtr ->
       with nullPtr    $ \curPtrPtr ->
         do let end = ptr `plusPtr` (off + len)
                curPtr = ptr `plusPtr` off
            poke curPtrPtr curPtr
            c_decode_utf8_with_state (A.maBA dest) destOffPtr curPtrPtr end codepointPtr statePtr
            state <- peek statePtr
            lastPtr <- peek curPtrPtr
            codepoint <- peek codepointPtr
            n <- peek destOffPtr
            chunkText <- mkText dest n
            let left      = lastPtr `minusPtr` curPtr
                remaining = B.drop left bs
                accum = if T.null chunkText then B.append old remaining  else remaining 
            return $! case state of 
              UTF8_REJECT -> Other chunkText accum -- We encountered an encoding error
              _ ->           Some  chunkText accum (decodeChunkUtf8 accum codepoint state)
     {-# INLINE decodeChunkToBuffer #-}
  {-# INLINE decodeChunkUtf8 #-}
{-# INLINE streamDecodeUtf8 #-}

decodeSomeUtf8 :: ByteString -> (Text, ByteString)
decodeSomeUtf8 bs@(PS fp off len) = runST $ do 
  dest <- A.new (len+1) 
  unsafeIOToST $ 
     withForeignPtr fp $ \ptr ->
     with (0::CSize)        $ \destOffPtr ->
     with (0::CodePoint)    $ \codepointPtr ->
     with (0::DecoderState) $ \statePtr ->
     with nullPtr           $ \curPtrPtr ->
       do let end = ptr `plusPtr` (off + len)
              curPtr = ptr `plusPtr` off
          poke curPtrPtr curPtr
          c_decode_utf8_with_state (A.maBA dest) destOffPtr 
                                   curPtrPtr end codepointPtr statePtr
          state <- peek statePtr
          lastPtr <- peek curPtrPtr
          codepoint <- peek codepointPtr
          n <- peek destOffPtr
          chunkText <- unsafeSTToIO $ do arr <- A.unsafeFreeze dest
                                         return $! textP arr 0 (fromIntegral n)
          let left      = lastPtr `minusPtr` curPtr
              remaining = B.drop left bs
          return $! (chunkText, remaining)
{-# INLINE decodeSomeUtf8 #-}

-- decodeSomeUtf8 :: ByteString -> (Text, ByteString)
-- decodeSomeUtf8 bs@(PS fp off len) = 
--                   runST $ do marray <- A.new (len+1) 
--                              unsafeIOToST (decodeChunkToBuffer marray)
--   
--      where
--      decodeChunkToBuffer :: A.MArray s -> IO (Text, ByteString)
--      decodeChunkToBuffer dest = withForeignPtr fp $ \ptr ->
--        with (0::CSize)        $ \destOffPtr ->
--        with (0::CodePoint)    $ \codepointPtr ->
--        with (0::DecoderState) $ \statePtr ->
--        with nullPtr           $ \curPtrPtr ->
--          do let end = ptr `plusPtr` (off + len)
--                 curPtr = ptr `plusPtr` off
--             poke curPtrPtr curPtr
--             c_decode_utf8_with_state (A.maBA dest) destOffPtr curPtrPtr end codepointPtr statePtr
--             state <- peek statePtr
--             lastPtr <- peek curPtrPtr
--             codepoint <- peek codepointPtr
--             n <- peek destOffPtr
--             chunkText <- unsafeSTToIO $ do arr <- A.unsafeFreeze dest
--                                            return $! textP arr 0 (fromIntegral n)
--             let left      = lastPtr `minusPtr` curPtr
--                 remaining = B.drop left bs
--             return $! (chunkText, remaining)
--      {-# INLINE decodeChunkToBuffer #-}
-- {-# INLINE decodeSomeUtf8 #-}



mkText :: A.MArray s -> CSize -> IO Text
mkText dest n =  unsafeSTToIO $ do arr <- A.unsafeFreeze dest
                                   return $! textP arr 0 (fromIntegral n)
{-# INLINE mkText #-}

ord :: Char -> Int
ord (C# c#) = I# (ord# c#)
{-# INLINE ord #-}

unsafeWrite :: A.MArray s -> Int -> Char -> ST s Int
unsafeWrite marr i c
    | n < 0x10000 = do A.unsafeWrite marr i (fromIntegral n)
                       return 1
    | otherwise   = do A.unsafeWrite marr i lo
                       A.unsafeWrite marr (i+1) hi
                       return 2
    where n = ord c
          m = n - 0x10000
          lo = fromIntegral $ (m `shiftR` 10) + 0xD800
          hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00
          shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#)
          {-# INLINE shiftR #-}
{-# INLINE unsafeWrite #-}

foreign import ccall unsafe "_hs_pipes_text_decode_utf8_state" c_decode_utf8_with_state
    :: MutableByteArray# s -> Ptr CSize
    -> Ptr (Ptr Word8) -> Ptr Word8
    -> Ptr CodePoint -> Ptr DecoderState -> IO (Ptr Word8)