src/Streamly/Internal/Unicode/Stream.hs · streamly

git.iko.soy/streamly

on cea6762 help sign in

streamly/src/Streamly/Internal/Unicode/Stream.hs

1081 lines 39 kB history raw

1-- |

2-- Module : Streamly.Internal.Unicode.Stream

4-- (c) Bjoern Hoehrmann 2008-2009

5--

6-- License : BSD-3-Clause

7-- Maintainer : streamly@composewell.com

8-- Stability : experimental

9-- Portability : GHC

10--

12module Streamly.Internal.Unicode.Stream

13 (

14 -- * Construction (Decoding)

15 decodeLatin1

17 -- ** UTF-8 Decoding

18 , CodingFailureMode(..)

19 , writeCharUtf8'

20 , parseCharUtf8With

21 , decodeUtf8

22 , decodeUtf8'

23 , decodeUtf8_

25 -- ** Resumable UTF-8 Decoding

26 , DecodeError(..)

27 , DecodeState

28 , CodePoint

29 , decodeUtf8Either

30 , resumeDecodeUtf8Either

32 -- ** UTF-8 Array Stream Decoding

33 , decodeUtf8Arrays

34 , decodeUtf8Arrays'

35 , decodeUtf8Arrays_

37 -- * Elimination (Encoding)

38 -- ** Latin1 Encoding

39 , encodeLatin1

40 , encodeLatin1'

41 , encodeLatin1_

43 -- ** UTF-8 Encoding

44 , readCharUtf8'

45 , encodeUtf8

46 , encodeUtf8'

47 , encodeUtf8_

48 , encodeStrings

49 {-

50 -- * Operations on character strings

51 , strip -- (dropAround isSpace)

52 , stripEnd

53 -}

55 -- * Transformation

56 , stripHead

57 , lines

58 , words

59 , unlines

60 , unwords

62 -- * StreamD UTF8 Encoding / Decoding transformations.

63 , decodeUtf8D

64 , decodeUtf8D'

65 , decodeUtf8D_

66 , encodeUtf8D

67 , encodeUtf8D'

68 , encodeUtf8D_

69 , decodeUtf8EitherD

70 , resumeDecodeUtf8EitherD

71 , decodeUtf8ArraysD

72 , decodeUtf8ArraysD'

73 , decodeUtf8ArraysD_

75 -- * Deprecations

76 , decodeUtf8Lax

77 , encodeLatin1Lax

78 , encodeUtf8Lax

79 )

80where

82#include "inline.hs"

84import Control.Monad.Catch (MonadThrow, MonadCatch)

85import Control.Monad.IO.Class (MonadIO, liftIO)

86import Data.Bits (shiftR, shiftL, (.|.), (.&.))

87import Data.Char (chr, ord)

88import Data.Word (Word8)

89import Foreign.Storable (Storable(..))

90import Fusion.Plugin.Types (Fuse(..))

91import GHC.Base (assert, unsafeChr)

92import GHC.IO.Encoding.Failure (isSurrogate)

93import GHC.Ptr (Ptr (..), plusPtr)

94import System.IO.Unsafe (unsafePerformIO)

95import Streamly.Internal.Data.Array.Foreign (Array)

96import Streamly.Internal.Data.Array.Foreign.Mut.Type (ArrayContents, touch)

97import Streamly.Internal.Data.Fold (Fold)

98import Streamly.Internal.Data.Stream.IsStream.Type

99 (IsStream, fromStreamD, toStreamD, adapt)

100import Streamly.Internal.Data.Stream.Serial (SerialT)

101import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))

102import Streamly.Internal.Data.SVar (adaptState)

103import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))

104import Streamly.Internal.Data.Unfold.Type (Unfold(..))

105import Streamly.Internal.System.IO (unsafeInlineIO)

106

107import qualified Streamly.Internal.Data.Unfold as Unfold

108import qualified Streamly.Internal.Data.Parser as Parser

109import qualified Streamly.Internal.Data.Parser.ParserD as ParserD

110import qualified Streamly.Internal.Data.Stream.Serial as Serial

111import qualified Streamly.Internal.Data.Array.Foreign as Array

112import qualified Streamly.Internal.Data.Array.Foreign.Type as A

113import qualified Streamly.Internal.Data.Stream.IsStream as S

114import qualified Streamly.Internal.Data.Stream.StreamD as D

115

116import Prelude hiding (lines, words, unlines, unwords)

117

118-- $setup

119-- >>> :m

120-- >>> import Prelude hiding (lines, words, unlines, unwords)

121-- >>> import qualified Streamly.Prelude as Stream

122-- >>> import qualified Streamly.Data.Fold as Fold

123-- >>> import Streamly.Internal.Unicode.Stream

124

125-------------------------------------------------------------------------------

126-- Latin1 decoding

127-------------------------------------------------------------------------------

128

129-- | Decode a stream of bytes to Unicode characters by mapping each byte to a

130-- corresponding Unicode 'Char' in 0-255 range.

131--

132-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/

133--

134-- @since 0.8.0

135{-# INLINE decodeLatin1 #-}

136decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char

137decodeLatin1 = S.map (unsafeChr . fromIntegral)

138

139-------------------------------------------------------------------------------

140-- Latin1 encoding

141-------------------------------------------------------------------------------

142

143-- | Encode a stream of Unicode characters to bytes by mapping each character

144-- to a byte in 0-255 range. Throws an error if the input stream contains

145-- characters beyond 255.

146--

147-- @since 0.8.0

148{-# INLINE encodeLatin1' #-}

149encodeLatin1' :: (IsStream t, Monad m) => t m Char -> t m Word8

150encodeLatin1' = S.map convert

151 where

152 convert c =

153 let codepoint = ord c

154 in if codepoint > 255

155 then error $ "Streamly.Unicode.encodeLatin1 invalid " ++

156 "input char codepoint " ++ show codepoint

157 else fromIntegral codepoint

158

159-- XXX Should we instead replace the invalid chars by NUL or whitespace or some

160-- other control char? That may affect the perf a bit but may be a better

161-- behavior.

162--

163-- | Like 'encodeLatin1'' but silently maps input codepoints beyond 255 to

164-- arbitrary Latin1 chars in 0-255 range. No error or exception is thrown when

165-- such mapping occurs.

166--

167-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/

168--

169-- /Since: 0.8.0 (Lenient Behaviour)/

170{-# INLINE encodeLatin1 #-}

171encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8

172encodeLatin1 = S.map (fromIntegral . ord)

173

174-- | Like 'encodeLatin1' but drops the input characters beyond 255.

175--

176-- @since 0.8.0

177{-# INLINE encodeLatin1_ #-}

178encodeLatin1_ :: (IsStream t, Monad m) => t m Char -> t m Word8

179encodeLatin1_ = S.map (fromIntegral . ord) . S.filter (<= chr 255)

180

181-- | Same as 'encodeLatin1'

182--

183{-# DEPRECATED encodeLatin1Lax "Please use 'encodeLatin1' instead" #-}

184{-# INLINE encodeLatin1Lax #-}

185encodeLatin1Lax :: (IsStream t, Monad m) => t m Char -> t m Word8

186encodeLatin1Lax = encodeLatin1

187

188-------------------------------------------------------------------------------

189-- UTF-8 decoding

190-------------------------------------------------------------------------------

191

192-- Int helps in cheaper conversion from Int to Char

193type CodePoint = Int

194type DecodeState = Word8

195

196-- We can divide the errors in three general categories:

197-- * A non-starter was encountered in a begin state

198-- * A starter was encountered without completing a codepoint

199-- * The last codepoint was not complete (input underflow)

200--

201-- Need to separate resumable and non-resumable error. In case of non-resumable

202-- error we can also provide the failing byte. In case of resumable error the

203-- state can be opaque.

204--

205data DecodeError = DecodeError !DecodeState !CodePoint deriving Show

206

207-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.

208

209-- XXX Use names decodeSuccess = 0, decodeFailure = 12

210

211decodeTable :: [Word8]

212decodeTable = [

213 -- The first part of the table maps bytes to character classes that

214 -- to reduce the size of the transition table and create bitmasks.

215 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,

216 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,

217 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,

218 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,

219 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,

220 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,

221 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,

222 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,

223

224 -- The second part is a transition table that maps a combination

225 -- of a state of the automaton and a character class to a state.

226 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,

227 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,

228 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,

229 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,

230 12,36,12,12,12,12,12,12,12,12,12,12

231 ]

232

233{-# NOINLINE utf8d #-}

234utf8d :: A.Array Word8

235utf8d =

236 unsafePerformIO

237 -- Aligning to cacheline makes a barely noticeable difference

238 -- XXX currently alignment is not implemented for unmanaged allocation

239 $ D.fold (A.writeNAlignedUnmanaged 64 (length decodeTable))

240 (D.fromList decodeTable)

241

242-- | Return element at the specified index without checking the bounds.

243-- and without touching the foreign ptr.

244{-# INLINE_NORMAL unsafePeekElemOff #-}

245unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a

246unsafePeekElemOff p i = let !x = unsafeInlineIO $ peekElemOff p i in x

247

248-- decode is split into two separate cases to avoid branching instructions.

249-- From the higher level flow we already know which case we are in so we can

250-- call the appropriate decode function.

251--

252-- When the state is 0

253{-# INLINE decode0 #-}

254decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint

255decode0 table byte =

256 let !t = table `unsafePeekElemOff` fromIntegral byte

257 !codep' = (0xff `shiftR` fromIntegral t) .&. fromIntegral byte

258 !state' = table `unsafePeekElemOff` (256 + fromIntegral t)

259 in assert ((byte > 0x7f || error showByte)

260 && (state' /= 0 || error (showByte ++ showTable)))

261 (Tuple' state' codep')

262

263 where

264

265 utf8table =

266 let end = table `plusPtr` 364

267 in A.Array undefined table end :: A.Array Word8

268 showByte = "Streamly: decode0: byte: " ++ show byte

269 showTable = " table: " ++ show utf8table

270

271-- When the state is not 0

272{-# INLINE decode1 #-}

273decode1

274 :: Ptr Word8

275 -> DecodeState

276 -> CodePoint

277 -> Word8

278 -> Tuple' DecodeState CodePoint

279decode1 table state codep byte =

280 -- Remember codep is Int type!

281 -- Can it be unsafe to convert the resulting Int to Char?

282 let !t = table `unsafePeekElemOff` fromIntegral byte

283 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)

284 !state' = table `unsafePeekElemOff`

285 (256 + fromIntegral state + fromIntegral t)

286 in assert (codep' <= 0x10FFFF

287 || error (showByte ++ showState state codep))

288 (Tuple' state' codep')

289 where

290

291 utf8table =

292 let end = table `plusPtr` 364

293 in A.Array undefined table end :: A.Array Word8

294 showByte = "Streamly: decode1: byte: " ++ show byte

295 showState st cp =

296 " state: " ++ show st ++

297 " codepoint: " ++ show cp ++

298 " table: " ++ show utf8table

299

300-------------------------------------------------------------------------------

301-- Resumable UTF-8 decoding

302-------------------------------------------------------------------------------

303

304-- Strangely, GHCJS hangs linking template-haskell with this

305#ifndef __GHCJS__

306{-# ANN type UTF8DecodeState Fuse #-}

307#endif

308data UTF8DecodeState s a

309 = UTF8DecodeInit s

310 | UTF8DecodeInit1 s Word8

311 | UTF8DecodeFirst s Word8

312 | UTF8Decoding s !DecodeState !CodePoint

313 | YieldAndContinue a (UTF8DecodeState s a)

314 | Done

315

316{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}

317resumeDecodeUtf8EitherD

318 :: Monad m

319 => DecodeState

320 -> CodePoint

321 -> Stream m Word8

322 -> Stream m (Either DecodeError Char)

323resumeDecodeUtf8EitherD dst codep (Stream step state) =

324 let A.Array _ p _ = utf8d

325 !ptr = p

326 stt =

327 if dst == 0

328 then UTF8DecodeInit state

329 else UTF8Decoding state dst codep

330 in Stream (step' ptr) stt

331 where

332 {-# INLINE_LATE step' #-}

333 step' _ gst (UTF8DecodeInit st) = do

334 r <- step (adaptState gst) st

335 return $ case r of

336 Yield x s -> Skip (UTF8DecodeInit1 s x)

337 Skip s -> Skip (UTF8DecodeInit s)

338 Stop -> Skip Done

339

340 step' _ _ (UTF8DecodeInit1 st x) = do

341 -- Note: It is important to use a ">" instead of a "<=" test

342 -- here for GHC to generate code layout for default branch

343 -- prediction for the common case. This is fragile and might

344 -- change with the compiler versions, we need a more reliable

345 -- "likely" primitive to control branch predication.

346 case x > 0x7f of

347 False ->

348 return $ Skip $ YieldAndContinue

349 (Right $ unsafeChr (fromIntegral x))

350 (UTF8DecodeInit st)

351 -- Using a separate state here generates a jump to a

352 -- separate code block in the core which seems to perform

353 -- slightly better for the non-ascii case.

354 True -> return $ Skip $ UTF8DecodeFirst st x

355

356 -- XXX should we merge it with UTF8DecodeInit1?

357 step' table _ (UTF8DecodeFirst st x) = do

358 let (Tuple' sv cp) = decode0 table x

359 return $

360 case sv of

361 12 ->

362 Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))

363 (UTF8DecodeInit st)

364 0 -> error "unreachable state"

365 _ -> Skip (UTF8Decoding st sv cp)

366

367 -- We recover by trying the new byte x a starter of a new codepoint.

368 -- XXX on error need to report the next byte "x" as well.

369 -- XXX need to use the same recovery in array decoding routine as well

370 step' table gst (UTF8Decoding st statePtr codepointPtr) = do

371 r <- step (adaptState gst) st

372 case r of

373 Yield x s -> do

374 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x

375 return $

376 case sv of

377 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp)

378 (UTF8DecodeInit s)

379 12 ->

380 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)

381 (UTF8DecodeInit1 s x)

382 _ -> Skip (UTF8Decoding s sv cp)

383 Skip s -> return $ Skip (UTF8Decoding s statePtr codepointPtr)

384 Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done

385

386 step' _ _ (YieldAndContinue c s) = return $ Yield c s

387 step' _ _ Done = return Stop

388

389-- XXX We can use just one API, and define InitState = 0 and InitCodePoint = 0

390-- to use as starting state.

391--

392{-# INLINE_NORMAL decodeUtf8EitherD #-}

393decodeUtf8EitherD :: Monad m

394 => Stream m Word8 -> Stream m (Either DecodeError Char)

395decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0

396

397-- |

398--

399-- /Pre-release/

400{-# INLINE decodeUtf8Either #-}

401decodeUtf8Either :: (Monad m, IsStream t)

402 => t m Word8 -> t m (Either DecodeError Char)

403decodeUtf8Either = fromStreamD . decodeUtf8EitherD . toStreamD

404

405-- |

406--

407-- /Pre-release/

408{-# INLINE resumeDecodeUtf8Either #-}

409resumeDecodeUtf8Either

410 :: (Monad m, IsStream t)

411 => DecodeState

412 -> CodePoint

413 -> t m Word8

414 -> t m (Either DecodeError Char)

415resumeDecodeUtf8Either st cp =

416 fromStreamD . resumeDecodeUtf8EitherD st cp . toStreamD

417

418-------------------------------------------------------------------------------

419-- One shot decoding

420-------------------------------------------------------------------------------

421

422data CodingFailureMode

423 = TransliterateCodingFailure

424 | ErrorOnCodingFailure

425 | DropOnCodingFailure

426 deriving (Show)

427

428{-# INLINE replacementChar #-}

429replacementChar :: Char

430replacementChar = '\xFFFD'

431

432data UTF8CharDecodeState a

433 = UTF8CharDecodeInit

434 | UTF8CharDecoding !DecodeState !CodePoint

435

436{-# INLINE parseCharUtf8WithD #-}

437parseCharUtf8WithD ::

438 Monad m => CodingFailureMode -> ParserD.Parser m Word8 Char

439parseCharUtf8WithD cfm =

440 let A.Array _ ptr _ = utf8d

441 in ParserD.Parser (step' ptr) initial extract

442

443 where

444

445 prefix = "Streamly.Internal.Data.Stream.parseCharUtf8WithD:"

446

447 {-# INLINE initial #-}

448 initial = return $ ParserD.IPartial UTF8CharDecodeInit

449

450 handleError err souldBackTrack =

451 case cfm of

452 ErrorOnCodingFailure -> ParserD.Error err

453 TransliterateCodingFailure ->

454 case souldBackTrack of

455 True -> ParserD.Done 1 replacementChar

456 False -> ParserD.Done 0 replacementChar

457 DropOnCodingFailure ->

458 case souldBackTrack of

459 True -> ParserD.Continue 1 UTF8CharDecodeInit

460 False -> ParserD.Continue 0 UTF8CharDecodeInit

461

462 {-# INLINE step' #-}

463 step' table UTF8CharDecodeInit x =

464 -- Note: It is important to use a ">" instead of a "<=" test

465 -- here for GHC to generate code layout for default branch

466 -- prediction for the common case. This is fragile and might

467 -- change with the compiler versions, we need a more reliable

468 -- "likely" primitive to control branch predication.

469 return $ case x > 0x7f of

470 False -> ParserD.Done 0 $ unsafeChr $ fromIntegral x

471 True ->

472 let (Tuple' sv cp) = decode0 table x

473 in case sv of

474 12 ->

475 let msg = prefix

476 ++ "Invalid first UTF8 byte" ++ show x

477 in handleError msg False

478 0 -> error $ prefix ++ "unreachable state"

479 _ -> ParserD.Continue 0 (UTF8CharDecoding sv cp)

480

481 step' table (UTF8CharDecoding statePtr codepointPtr) x = return $

482 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x

483 in case sv of

484 0 -> ParserD.Done 0 $ unsafeChr cp

485 12 ->

486 let msg = prefix

487 ++ "Invalid subsequent UTF8 byte"

488 ++ show x

489 ++ "in state"

490 ++ show statePtr

491 ++ "accumulated value"

492 ++ show codepointPtr

493 in handleError msg True

494 _ -> ParserD.Continue 0 (UTF8CharDecoding sv cp)

495

496 {-# INLINE extract #-}

497 extract _ = error $ prefix ++ "Not enough input"

498

499-- XXX This should ideally accept a "CodingFailureMode" and perform appropriate

500-- error handling. This isn't possible now as "TransliterateCodingFailure"'s

501-- workflow requires backtracking 1 element. This can be revisited once "Fold"

502-- supports backtracking.

503{-# INLINE writeCharUtf8' #-}

504writeCharUtf8' :: MonadThrow m => Fold m Word8 Char

505writeCharUtf8' = ParserD.toFold (parseCharUtf8WithD ErrorOnCodingFailure)

506

507-- XXX The initial idea was to have "parseCharUtf8" and offload the error

508-- handling to another parser. So, say we had "parseCharUtf8'",

509--

510-- >>> parseCharUtf8Smart = parseCharUtf8' <|> Parser.fromPure replacementChar

511--

512-- But unfortunately parseCharUtf8Smart used in conjunction with "parseMany" -

513-- that is "parseMany parseCharUtf8Smart" on a stream causes the heap to

514-- overflow. Even a heap size of 500 MB was not sufficient.

515--

516-- This needs to be investigated futher.

517{-# INLINE parseCharUtf8With #-}

518parseCharUtf8With ::

519 MonadCatch m => CodingFailureMode -> Parser.Parser m Word8 Char

520parseCharUtf8With = ParserD.toParserK . parseCharUtf8WithD

521

522-- XXX write it as a parser and use parseMany to decode a stream, need to check

523-- if that preserves the same performance. Or we can use a resumable parser

524-- that parses a chunk at a time.

525--

526-- XXX Implement this in terms of decodeUtf8Either. Need to make sure that

527-- decodeUtf8Either preserves the performance characterstics.

528--

529{-# INLINE_NORMAL decodeUtf8WithD #-}

530decodeUtf8WithD :: Monad m

531 => CodingFailureMode -> Stream m Word8 -> Stream m Char

532decodeUtf8WithD cfm (Stream step state) =

533 let A.Array _ ptr _ = utf8d

534 in Stream (step' ptr) (UTF8DecodeInit state)

535

536 where

537

538 prefix = "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: "

539

540 {-# INLINE handleError #-}

541 handleError e s =

542 case cfm of

543 ErrorOnCodingFailure -> error e

544 TransliterateCodingFailure -> YieldAndContinue replacementChar s

545 DropOnCodingFailure -> s

546

547 {-# INLINE handleUnderflow #-}

548 handleUnderflow =

549 case cfm of

550 ErrorOnCodingFailure -> error $ prefix ++ "Not enough input"

551 TransliterateCodingFailure -> YieldAndContinue replacementChar Done

552 DropOnCodingFailure -> Done

553

554 {-# INLINE_LATE step' #-}

555 step' _ gst (UTF8DecodeInit st) = do

556 r <- step (adaptState gst) st

557 return $ case r of

558 Yield x s -> Skip (UTF8DecodeInit1 s x)

559 Skip s -> Skip (UTF8DecodeInit s)

560 Stop -> Skip Done

561

562 step' _ _ (UTF8DecodeInit1 st x) = do

563 -- Note: It is important to use a ">" instead of a "<=" test

564 -- here for GHC to generate code layout for default branch

565 -- prediction for the common case. This is fragile and might

566 -- change with the compiler versions, we need a more reliable

567 -- "likely" primitive to control branch predication.

568 case x > 0x7f of

569 False ->

570 return $ Skip $ YieldAndContinue

571 (unsafeChr (fromIntegral x))

572 (UTF8DecodeInit st)

573 -- Using a separate state here generates a jump to a

574 -- separate code block in the core which seems to perform

575 -- slightly better for the non-ascii case.

576 True -> return $ Skip $ UTF8DecodeFirst st x

577

578 -- XXX should we merge it with UTF8DecodeInit1?

579 step' table _ (UTF8DecodeFirst st x) = do

580 let (Tuple' sv cp) = decode0 table x

581 return $

582 case sv of

583 12 ->

584 let msg = prefix ++ "Invalid first UTF8 byte " ++ show x

585 in Skip $ handleError msg (UTF8DecodeInit st)

586 0 -> error "unreachable state"

587 _ -> Skip (UTF8Decoding st sv cp)

588

589 -- We recover by trying the new byte x as a starter of a new codepoint.

590 -- XXX need to use the same recovery in array decoding routine as well

591 step' table gst (UTF8Decoding st statePtr codepointPtr) = do

592 r <- step (adaptState gst) st

593 case r of

594 Yield x s -> do

595 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x

596 return $ case sv of

597 0 -> Skip $ YieldAndContinue

598 (unsafeChr cp) (UTF8DecodeInit s)

599 12 ->

600 let msg = prefix

601 ++ "Invalid subsequent UTF8 byte "

602 ++ show x

603 ++ " in state "

604 ++ show statePtr

605 ++ " accumulated value "

606 ++ show codepointPtr

607 in Skip $ handleError msg (UTF8DecodeInit1 s x)

608 _ -> Skip (UTF8Decoding s sv cp)

609 Skip s -> return $

610 Skip (UTF8Decoding s statePtr codepointPtr)

611 Stop -> return $ Skip handleUnderflow

612

613 step' _ _ (YieldAndContinue c s) = return $ Yield c s

614 step' _ _ Done = return Stop

615

616{-# INLINE decodeUtf8D #-}

617decodeUtf8D :: Monad m => Stream m Word8 -> Stream m Char

618decodeUtf8D = decodeUtf8WithD TransliterateCodingFailure

619

620-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.

621-- Any invalid codepoint encountered is replaced with the unicode replacement

622-- character.

623--

624-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/

625--

626-- /Since: 0.8.0 (Lenient Behaviour)/

627{-# INLINE decodeUtf8 #-}

628decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char

629decodeUtf8 = fromStreamD . decodeUtf8D . toStreamD

630

631{-# INLINE decodeUtf8D' #-}

632decodeUtf8D' :: Monad m => Stream m Word8 -> Stream m Char

633decodeUtf8D' = decodeUtf8WithD ErrorOnCodingFailure

634

635-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.

636-- The function throws an error if an invalid codepoint is encountered.

637--

638-- @since 0.8.0

639{-# INLINE decodeUtf8' #-}

640decodeUtf8' :: (Monad m, IsStream t) => t m Word8 -> t m Char

641decodeUtf8' = fromStreamD . decodeUtf8D' . toStreamD

642

643{-# INLINE decodeUtf8D_ #-}

644decodeUtf8D_ :: Monad m => Stream m Word8 -> Stream m Char

645decodeUtf8D_ = decodeUtf8WithD DropOnCodingFailure

646

647-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.

648-- Any invalid codepoint encountered is dropped.

649--

650-- @since 0.8.0

651{-# INLINE decodeUtf8_ #-}

652decodeUtf8_ :: (Monad m, IsStream t) => t m Word8 -> t m Char

653decodeUtf8_ = fromStreamD . decodeUtf8D_ . toStreamD

654

655-- | Same as 'decodeUtf8'

656--

657{-# DEPRECATED decodeUtf8Lax "Please use 'decodeUtf8' instead" #-}

658{-# INLINE decodeUtf8Lax #-}

659decodeUtf8Lax :: (IsStream t, Monad m) => t m Word8 -> t m Char

660decodeUtf8Lax = decodeUtf8

661

662-------------------------------------------------------------------------------

663-- Decoding Array Streams

664-------------------------------------------------------------------------------

665

666#ifndef __GHCJS__

667{-# ANN type FlattenState Fuse #-}

668#endif

669data FlattenState s a

670 = OuterLoop s !(Maybe (DecodeState, CodePoint))

671 | InnerLoopDecodeInit s ArrayContents !(Ptr a) !(Ptr a)

672 | InnerLoopDecodeFirst s ArrayContents !(Ptr a) !(Ptr a) Word8

673 | InnerLoopDecoding s ArrayContents !(Ptr a) !(Ptr a)

674 !DecodeState !CodePoint

675 | YAndC !Char (FlattenState s a) -- These constructors can be

676 -- encoded in the UTF8DecodeState

677 -- type, I prefer to keep these

678 -- flat even though that means

679 -- coming up with new names

680 | D

681

682-- The normal decodeUtf8 above should fuse with flattenArrays

683-- to create this exact code but it doesn't for some reason, as of now this

684-- remains the fastest way I could figure out to decodeUtf8.

685--

686-- XXX Add Proper error messages

687{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}

688decodeUtf8ArraysWithD ::

689 MonadIO m

690 => CodingFailureMode

691 -> Stream m (A.Array Word8)

692 -> Stream m Char

693decodeUtf8ArraysWithD cfm (Stream step state) =

694 let A.Array _ ptr _ = utf8d

695 in Stream (step' ptr) (OuterLoop state Nothing)

696 where

697 {-# INLINE transliterateOrError #-}

698 transliterateOrError e s =

699 case cfm of

700 ErrorOnCodingFailure -> error e

701 TransliterateCodingFailure -> YAndC replacementChar s

702 DropOnCodingFailure -> s

703 {-# INLINE inputUnderflow #-}

704 inputUnderflow =

705 case cfm of

706 ErrorOnCodingFailure ->

707 error $

708 show "Streamly.Internal.Data.Stream.StreamD."

709 ++ "decodeUtf8ArraysWith: Input Underflow"

710 TransliterateCodingFailure -> YAndC replacementChar D

711 DropOnCodingFailure -> D

712 {-# INLINE_LATE step' #-}

713 step' _ gst (OuterLoop st Nothing) = do

714 r <- step (adaptState gst) st

715 return $

716 case r of

717 Yield A.Array {..} s ->

718 Skip (InnerLoopDecodeInit s arrContents arrStart aEnd)

719 Skip s -> Skip (OuterLoop s Nothing)

720 Stop -> Skip D

721 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do

722 r <- step (adaptState gst) st

723 return $

724 case r of

725 Yield A.Array {..} s ->

726 Skip (InnerLoopDecoding s arrContents arrStart aEnd ds cp)

727 Skip s -> Skip (OuterLoop s dst)

728 Stop -> Skip inputUnderflow

729 step' _ _ (InnerLoopDecodeInit st startf p end)

730 | p == end = do

731 liftIO $ touch startf

732 return $ Skip $ OuterLoop st Nothing

733 step' _ _ (InnerLoopDecodeInit st startf p end) = do

734 x <- liftIO $ peek p

735 -- Note: It is important to use a ">" instead of a "<=" test here for

736 -- GHC to generate code layout for default branch prediction for the

737 -- common case. This is fragile and might change with the compiler

738 -- versions, we need a more reliable "likely" primitive to control

739 -- branch predication.

740 case x > 0x7f of

741 False ->

742 return $ Skip $ YAndC

743 (unsafeChr (fromIntegral x))

744 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

745 -- Using a separate state here generates a jump to a separate code

746 -- block in the core which seems to perform slightly better for the

747 -- non-ascii case.

748 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x

749

750 step' table _ (InnerLoopDecodeFirst st startf p end x) = do

751 let (Tuple' sv cp) = decode0 table x

752 return $

753 case sv of

754 12 ->

755 Skip $

756 transliterateOrError

757 (

758 "Streamly.Internal.Data.Stream.StreamD."

759 ++ "decodeUtf8ArraysWith: Invalid UTF8"

760 ++ " codepoint encountered"

761 )

762 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

763 0 -> error "unreachable state"

764 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)

765 step' _ _ (InnerLoopDecoding st startf p end sv cp)

766 | p == end = do

767 liftIO $ touch startf

768 return $ Skip $ OuterLoop st (Just (sv, cp))

769 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do

770 x <- liftIO $ peek p

771 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x

772 return $

773 case sv of

774 0 ->

775 Skip $

776 YAndC

777 (unsafeChr cp)

778 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

779 12 ->

780 Skip $

781 transliterateOrError

782 (

783 "Streamly.Internal.Data.Stream.StreamD."

784 ++ "decodeUtf8ArraysWith: Invalid UTF8"

785 ++ " codepoint encountered"

786 )

787 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

788 _ ->

789 Skip

790 (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)

791 step' _ _ (YAndC c s) = return $ Yield c s

792 step' _ _ D = return Stop

793

794{-# INLINE decodeUtf8ArraysD #-}

795decodeUtf8ArraysD ::

796 MonadIO m

797 => Stream m (A.Array Word8)

798 -> Stream m Char

799decodeUtf8ArraysD = decodeUtf8ArraysWithD TransliterateCodingFailure

800

801-- |

802--

803-- /Pre-release/

804{-# INLINE decodeUtf8Arrays #-}

805decodeUtf8Arrays ::

806 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char

807decodeUtf8Arrays =

808 fromStreamD . decodeUtf8ArraysD . toStreamD

809

810{-# INLINE decodeUtf8ArraysD' #-}

811decodeUtf8ArraysD' ::

812 MonadIO m

813 => Stream m (A.Array Word8)

814 -> Stream m Char

815decodeUtf8ArraysD' = decodeUtf8ArraysWithD ErrorOnCodingFailure

816

817-- |

818--

819-- /Pre-release/

820{-# INLINE decodeUtf8Arrays' #-}

821decodeUtf8Arrays' :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char

822decodeUtf8Arrays' = fromStreamD . decodeUtf8ArraysD' . toStreamD

823

824{-# INLINE decodeUtf8ArraysD_ #-}

825decodeUtf8ArraysD_ ::

826 MonadIO m

827 => Stream m (A.Array Word8)

828 -> Stream m Char

829decodeUtf8ArraysD_ = decodeUtf8ArraysWithD DropOnCodingFailure

830

831-- |

832--

833-- /Pre-release/

834{-# INLINE decodeUtf8Arrays_ #-}

835decodeUtf8Arrays_ ::

836 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char

837decodeUtf8Arrays_ =

838 fromStreamD . decodeUtf8ArraysD_ . toStreamD

839

840-------------------------------------------------------------------------------

841-- Encoding Unicode (UTF-8) Characters

842-------------------------------------------------------------------------------

843

844data WList = WCons !Word8 !WList | WNil

845

846-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.

847

848{-# INLINE ord2 #-}

849ord2 :: Char -> WList

850ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))

851 where

852 n = ord c

853 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0

854 x2 = fromIntegral $ (n .&. 0x3F) + 0x80

855

856{-# INLINE ord3 #-}

857ord3 :: Char -> WList

858ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))

859 where

860 n = ord c

861 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0

862 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80

863 x3 = fromIntegral $ (n .&. 0x3F) + 0x80

864

865{-# INLINE ord4 #-}

866ord4 :: Char -> WList

867ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))

868 where

869 n = ord c

870 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0

871 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80

872 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80

873 x4 = fromIntegral $ (n .&. 0x3F) + 0x80

874

875{-# INLINE_NORMAL readCharUtf8With #-}

876readCharUtf8With :: Monad m => WList -> Unfold m Char Word8

877readCharUtf8With surr = Unfold step inject

878

879 where

880

881 inject c =

882 return $ case ord c of

883 x | x <= 0x7F -> fromIntegral x `WCons` WNil

884 | x <= 0x7FF -> ord2 c

885 | x <= 0xFFFF -> if isSurrogate c then surr else ord3 c

886 | otherwise -> ord4 c

887

888 {-# INLINE_LATE step #-}

889 step WNil = return Stop

890 step (WCons x xs) = return $ Yield x xs

891

892{-# INLINE_NORMAL readCharUtf8' #-}

893readCharUtf8' :: Monad m => Unfold m Char Word8

894readCharUtf8' =

895 readCharUtf8With $

896 error "Streamly.Internal.Unicode.readCharUtf8': Encountered a surrogate"

897

898-- More yield points improve performance, but I am not sure if they can cause

899-- too much code bloat or some trouble with fusion. So keeping only two yield

900-- points for now, one for the ascii chars (fast path) and one for all other

901-- paths (slow path).

902{-# INLINE_NORMAL encodeUtf8D' #-}

903encodeUtf8D' :: Monad m => Stream m Char -> Stream m Word8

904encodeUtf8D' = D.unfoldMany readCharUtf8'

905

906-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. When

907-- any invalid character (U+D800-U+D8FF) is encountered in the input stream the

908-- function errors out.

909--

910-- @since 0.8.0

911{-# INLINE encodeUtf8' #-}

912encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8

913encodeUtf8' = fromStreamD . encodeUtf8D' . toStreamD

914

915{-# INLINE_NORMAL readCharUtf8 #-}

916readCharUtf8 :: Monad m => Unfold m Char Word8

917readCharUtf8 = readCharUtf8With $ WCons 239 (WCons 191 (WCons 189 WNil))

918

919-- | See section "3.9 Unicode Encoding Forms" in

920-- https://www.unicode.org/versions/Unicode13.0.0/UnicodeStandard-13.0.pdf

921--

922{-# INLINE_NORMAL encodeUtf8D #-}

923encodeUtf8D :: Monad m => Stream m Char -> Stream m Word8

924encodeUtf8D = D.unfoldMany readCharUtf8

925

926-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any

927-- Invalid characters (U+D800-U+D8FF) in the input stream are replaced by the

928-- Unicode replacement character U+FFFD.

929--

930-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/

931--

932-- /Since: 0.8.0 (Lenient Behaviour)/

933{-# INLINE encodeUtf8 #-}

934encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8

935encodeUtf8 = fromStreamD . encodeUtf8D . toStreamD

936

937{-# INLINE_NORMAL readCharUtf8_ #-}

938readCharUtf8_ :: Monad m => Unfold m Char Word8

939readCharUtf8_ = readCharUtf8With WNil

940

941{-# INLINE_NORMAL encodeUtf8D_ #-}

942encodeUtf8D_ :: Monad m => Stream m Char -> Stream m Word8

943encodeUtf8D_ = D.unfoldMany readCharUtf8_

944

945-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any

946-- Invalid characters (U+D800-U+D8FF) in the input stream are dropped.

947--

948-- @since 0.8.0

949{-# INLINE encodeUtf8_ #-}

950encodeUtf8_ :: (Monad m, IsStream t) => t m Char -> t m Word8

951encodeUtf8_ = fromStreamD . encodeUtf8D_ . toStreamD

952

953-- | Same as 'encodeUtf8'

954--

955{-# DEPRECATED encodeUtf8Lax "Please use 'encodeUtf8' instead" #-}

956{-# INLINE encodeUtf8Lax #-}

957encodeUtf8Lax :: (IsStream t, Monad m) => t m Char -> t m Word8

958encodeUtf8Lax = encodeUtf8

959

960-------------------------------------------------------------------------------

961-- Encode streams of containers

962-------------------------------------------------------------------------------

963

964-- | Encode a container to @Array Word8@ provided an unfold to covert it to a

965-- Char stream and an encoding function.

966--

967-- /Internal/

968{-# INLINE encodeObject #-}

969encodeObject :: MonadIO m =>

970 (SerialT m Char -> SerialT m Word8)

971 -> Unfold m a Char

972 -> a

973 -> m (Array Word8)

974encodeObject encode u = S.fold Array.write . encode . S.unfold u

975

976-- | Encode a stream of container objects using the supplied encoding scheme.

977-- Each object is encoded as an @Array Word8@.

978--

979-- /Internal/

980{-# INLINE encodeObjects #-}

981encodeObjects :: (MonadIO m, IsStream t) =>

982 (SerialT m Char -> SerialT m Word8)

983 -> Unfold m a Char

984 -> t m a

985 -> t m (Array Word8)

986encodeObjects encode u = adapt . Serial.mapM (encodeObject encode u) . adapt

987

988-- | Encode a stream of 'String' using the supplied encoding scheme. Each

989-- string is encoded as an @Array Word8@.

990--

991-- @since 0.8.0

992{-# INLINE encodeStrings #-}

993encodeStrings :: (MonadIO m, IsStream t) =>

994 (SerialT m Char -> SerialT m Word8) -> t m String -> t m (Array Word8)

995encodeStrings encode = encodeObjects encode Unfold.fromList

996

997{-

998-------------------------------------------------------------------------------

999-- Utility operations on strings

1000-------------------------------------------------------------------------------

1001

1002strip :: IsStream t => t m Char -> t m Char

1003strip = undefined

1004

1005stripTail :: IsStream t => t m Char -> t m Char

1006stripTail = undefined

1007-}

1008

1009-- | Remove leading whitespace from a string.

1010--

1011-- > stripHead = S.dropWhile isSpace

1012--

1013-- /Pre-release/

1014{-# INLINE stripHead #-}

1015stripHead :: (Monad m, IsStream t) => t m Char -> t m Char

1016stripHead = S.dropWhile isSpace

1017

1018-- | Fold each line of the stream using the supplied 'Fold'

1019-- and stream the result.

1020--

1021-- >>> Stream.toList $ lines Fold.toList (Stream.fromList "lines\nthis\nstring\n\n\n")

1022-- ["lines","this","string","",""]

1023--

1024-- > lines = S.splitOnSuffix (== '\n')

1025--

1026-- /Pre-release/

1027{-# INLINE lines #-}

1028lines :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b

1029lines = S.splitOnSuffix (== '\n')

1030

1031foreign import ccall unsafe "u_iswspace"

1032 iswspace :: Int -> Int

1033

1034-- | Code copied from base/Data.Char to INLINE it

1035{-# INLINE isSpace #-}

1036isSpace :: Char -> Bool

1037isSpace c

1038 | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0

1039 | otherwise = iswspace (ord c) /= 0

1040 where

1041 uc = fromIntegral (ord c) :: Word

1042

1043-- | Fold each word of the stream using the supplied 'Fold'

1044-- and stream the result.

1045--

1046-- >>> Stream.toList $ words Fold.toList (Stream.fromList "fold these words")

1047-- ["fold","these","words"]

1048--

1049-- > words = S.wordsBy isSpace

1050--

1051-- /Pre-release/

1052{-# INLINE words #-}

1053words :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b

1054words = S.wordsBy isSpace

1055

1056-- | Unfold a stream to character streams using the supplied 'Unfold'

1057-- and concat the results suffixing a newline character @\\n@ to each stream.

1058--

1059-- @

1060-- unlines = Stream.interposeSuffix '\n'

1061-- unlines = Stream.intercalateSuffix Unfold.fromList "\n"

1062-- @

1063--

1064-- /Pre-release/

1065{-# INLINE unlines #-}

1066unlines :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char

1067unlines = S.interposeSuffix '\n'

1068

1069-- | Unfold the elements of a stream to character streams using the supplied

1070-- 'Unfold' and concat the results with a whitespace character infixed between

1071-- the streams.

1072--

1073-- @

1074-- unwords = Stream.interpose ' '

1075-- unwords = Stream.intercalate Unfold.fromList " "

1076-- @

1077--

1078-- /Pre-release/

1079{-# INLINE unwords #-}

1080unwords :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char

1081unwords = S.interpose ' '