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

git.iko.soy/streamly

on fab76f2 help sign in

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

1098 lines 40 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)

88#if MIN_VERSION_base(4,17,0)

89import Data.Char (generalCategory, GeneralCategory(Space))

90#endif

91import Data.Word (Word8)

92import Foreign.Storable (Storable(..))

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

94import GHC.Base (assert, unsafeChr)

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

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

97import System.IO.Unsafe (unsafePerformIO)

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

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

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

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

102 (IsStream, fromStreamD, toStreamD, adapt)

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

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

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

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

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

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

109

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

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

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

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

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

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

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

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

118

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

120

121-- $setup

122-- >>> :m

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

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

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

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

127

128-------------------------------------------------------------------------------

129-- Latin1 decoding

130-------------------------------------------------------------------------------

131

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

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

134--

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

136--

137-- @since 0.8.0

138{-# INLINE decodeLatin1 #-}

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

140decodeLatin1 = S.map (unsafeChr . fromIntegral)

141

142-------------------------------------------------------------------------------

143-- Latin1 encoding

144-------------------------------------------------------------------------------

145

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

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

148-- characters beyond 255.

149--

150-- @since 0.8.0

151{-# INLINE encodeLatin1' #-}

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

153encodeLatin1' = S.map convert

154 where

155 convert c =

156 let codepoint = ord c

157 in if codepoint > 255

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

159 "input char codepoint " ++ show codepoint

160 else fromIntegral codepoint

161

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

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

164-- behavior.

165--

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

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

168-- such mapping occurs.

169--

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

171--

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

173{-# INLINE encodeLatin1 #-}

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

175encodeLatin1 = S.map (fromIntegral . ord)

176

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

178--

179-- @since 0.8.0

180{-# INLINE encodeLatin1_ #-}

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

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

183

184-- | Same as 'encodeLatin1'

185--

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

187{-# INLINE encodeLatin1Lax #-}

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

189encodeLatin1Lax = encodeLatin1

190

191-------------------------------------------------------------------------------

192-- UTF-8 decoding

193-------------------------------------------------------------------------------

194

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

196type CodePoint = Int

197type DecodeState = Word8

198

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

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

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

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

203--

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

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

206-- state can be opaque.

207--

208data DecodeError = DecodeError !DecodeState !CodePoint deriving Show

209

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

211

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

213

214decodeTable :: [Word8]

215decodeTable = [

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

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

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 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,

220 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,

221 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,

222 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,

223 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,

224 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,

225 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,

226

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

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

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

230 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,

231 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,

232 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,

233 12,36,12,12,12,12,12,12,12,12,12,12

234 ]

235

236{-# NOINLINE utf8d #-}

237utf8d :: A.Array Word8

238utf8d =

239 unsafePerformIO

240 -- Aligning to cacheline makes a barely noticeable difference

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

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

243 (D.fromList decodeTable)

244

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

246-- and without touching the foreign ptr.

247{-# INLINE_NORMAL unsafePeekElemOff #-}

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

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

250

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

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

253-- call the appropriate decode function.

254--

255-- When the state is 0

256{-# INLINE decode0 #-}

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

258decode0 table byte =

259 let !t = table `unsafePeekElemOff` fromIntegral byte

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

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

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

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

264 (Tuple' state' codep')

265

266 where

267

268 utf8table =

269 let end = table `plusPtr` 364

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

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

272 showTable = " table: " ++ show utf8table

273

274-- When the state is not 0

275{-# INLINE decode1 #-}

276decode1

277 :: Ptr Word8

278 -> DecodeState

279 -> CodePoint

280 -> Word8

281 -> Tuple' DecodeState CodePoint

282decode1 table state codep byte =

283 -- Remember codep is Int type!

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

285 let !t = table `unsafePeekElemOff` fromIntegral byte

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

287 !state' = table `unsafePeekElemOff`

288 (256 + fromIntegral state + fromIntegral t)

289 in assert (codep' <= 0x10FFFF

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

291 (Tuple' state' codep')

292 where

293

294 utf8table =

295 let end = table `plusPtr` 364

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

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

298 showState st cp =

299 " state: " ++ show st ++

300 " codepoint: " ++ show cp ++

301 " table: " ++ show utf8table

302

303-------------------------------------------------------------------------------

304-- Resumable UTF-8 decoding

305-------------------------------------------------------------------------------

306

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

308#ifndef __GHCJS__

309{-# ANN type UTF8DecodeState Fuse #-}

310#endif

311data UTF8DecodeState s a

312 = UTF8DecodeInit s

313 | UTF8DecodeInit1 s Word8

314 | UTF8DecodeFirst s Word8

315 | UTF8Decoding s !DecodeState !CodePoint

316 | YieldAndContinue a (UTF8DecodeState s a)

317 | Done

318

319{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}

320resumeDecodeUtf8EitherD

321 :: Monad m

322 => DecodeState

323 -> CodePoint

324 -> Stream m Word8

325 -> Stream m (Either DecodeError Char)

326resumeDecodeUtf8EitherD dst codep (Stream step state) =

327 let A.Array _ p _ = utf8d

328 !ptr = p

329 stt =

330 if dst == 0

331 then UTF8DecodeInit state

332 else UTF8Decoding state dst codep

333 in Stream (step' ptr) stt

334 where

335 {-# INLINE_LATE step' #-}

336 step' _ gst (UTF8DecodeInit st) = do

337 r <- step (adaptState gst) st

338 return $ case r of

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

340 Skip s -> Skip (UTF8DecodeInit s)

341 Stop -> Skip Done

342

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

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

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

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

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

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

349 case x > 0x7f of

350 False ->

351 return $ Skip $ YieldAndContinue

352 (Right $ unsafeChr (fromIntegral x))

353 (UTF8DecodeInit st)

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

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

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

357 True -> return $ Skip $ UTF8DecodeFirst st x

358

359 -- XXX should we merge it with UTF8DecodeInit1?

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

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

362 return $

363 case sv of

364 12 ->

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

366 (UTF8DecodeInit st)

367 0 -> error "unreachable state"

368 _ -> Skip (UTF8Decoding st sv cp)

369

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

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

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

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

374 r <- step (adaptState gst) st

375 case r of

376 Yield x s -> do

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

378 return $

379 case sv of

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

381 (UTF8DecodeInit s)

382 12 ->

383 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)

384 (UTF8DecodeInit1 s x)

385 _ -> Skip (UTF8Decoding s sv cp)

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

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

388

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

390 step' _ _ Done = return Stop

391

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

393-- to use as starting state.

394--

395{-# INLINE_NORMAL decodeUtf8EitherD #-}

396decodeUtf8EitherD :: Monad m

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

398decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0

399

400-- |

401--

402-- /Pre-release/

403{-# INLINE decodeUtf8Either #-}

404decodeUtf8Either :: (Monad m, IsStream t)

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

406decodeUtf8Either = fromStreamD . decodeUtf8EitherD . toStreamD

407

408-- |

409--

410-- /Pre-release/

411{-# INLINE resumeDecodeUtf8Either #-}

412resumeDecodeUtf8Either

413 :: (Monad m, IsStream t)

414 => DecodeState

415 -> CodePoint

416 -> t m Word8

417 -> t m (Either DecodeError Char)

418resumeDecodeUtf8Either st cp =

419 fromStreamD . resumeDecodeUtf8EitherD st cp . toStreamD

420

421-------------------------------------------------------------------------------

422-- One shot decoding

423-------------------------------------------------------------------------------

424

425data CodingFailureMode

426 = TransliterateCodingFailure

427 | ErrorOnCodingFailure

428 | DropOnCodingFailure

429 deriving (Show)

430

431{-# INLINE replacementChar #-}

432replacementChar :: Char

433replacementChar = '\xFFFD'

434

435data UTF8CharDecodeState a

436 = UTF8CharDecodeInit

437 | UTF8CharDecoding !DecodeState !CodePoint

438

439{-# INLINE parseCharUtf8WithD #-}

440parseCharUtf8WithD ::

441 MonadThrow m => CodingFailureMode -> ParserD.Parser m Word8 Char

442parseCharUtf8WithD cfm =

443 let A.Array _ ptr _ = utf8d

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

445

446 where

447

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

449

450 {-# INLINE initial #-}

451 initial = return $ ParserD.IPartial UTF8CharDecodeInit

452

453 handleError err souldBackTrack =

454 case cfm of

455 ErrorOnCodingFailure -> ParserD.Error err

456 TransliterateCodingFailure ->

457 case souldBackTrack of

458 True -> ParserD.Done 1 replacementChar

459 False -> ParserD.Done 0 replacementChar

460 DropOnCodingFailure ->

461 case souldBackTrack of

462 True -> ParserD.Continue 1 UTF8CharDecodeInit

463 False -> ParserD.Continue 0 UTF8CharDecodeInit

464

465 {-# INLINE step' #-}

466 step' table UTF8CharDecodeInit x =

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

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

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

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

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

472 return $ case x > 0x7f of

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

474 True ->

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

476 in case sv of

477 12 ->

478 let msg = prefix

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

480 in handleError msg False

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

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

483

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

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

486 in case sv of

487 0 -> ParserD.Done 0 $ unsafeChr cp

488 12 ->

489 let msg = prefix

490 ++ "Invalid subsequent UTF8 byte"

491 ++ show x

492 ++ "in state"

493 ++ show statePtr

494 ++ "accumulated value"

495 ++ show codepointPtr

496 in handleError msg True

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

498

499 {-# INLINE extract #-}

500 extract UTF8CharDecodeInit = error $ prefix ++ "Not enough input"

501 extract (UTF8CharDecoding _ _) =

502 case cfm of

503 ErrorOnCodingFailure ->

504 throwM $ ParserD.ParseError $ prefix ++ "Not enough input"

505 TransliterateCodingFailure -> return replacementChar

506 -- XXX We shouldn't error out here. There is no way to represent an

507 -- empty parser result unless we return a "Maybe" type.

508 DropOnCodingFailure -> error $ prefix ++ "Not enough input"

509

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

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

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

513-- supports backtracking.

514{-# INLINE writeCharUtf8' #-}

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

516writeCharUtf8' = ParserD.toFold (parseCharUtf8WithD ErrorOnCodingFailure)

517

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

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

520--

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

522--

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

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

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

526--

527-- This needs to be investigated futher.

528{-# INLINE parseCharUtf8With #-}

529parseCharUtf8With ::

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

531parseCharUtf8With = ParserD.toParserK . parseCharUtf8WithD

532

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

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

535-- that parses a chunk at a time.

536--

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

538-- decodeUtf8Either preserves the performance characterstics.

539--

540{-# INLINE_NORMAL decodeUtf8WithD #-}

541decodeUtf8WithD :: Monad m

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

543decodeUtf8WithD cfm (Stream step state) =

544 let A.Array _ ptr _ = utf8d

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

546

547 where

548

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

550

551 {-# INLINE handleError #-}

552 handleError e s =

553 case cfm of

554 ErrorOnCodingFailure -> error e

555 TransliterateCodingFailure -> YieldAndContinue replacementChar s

556 DropOnCodingFailure -> s

557

558 {-# INLINE handleUnderflow #-}

559 handleUnderflow =

560 case cfm of

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

562 TransliterateCodingFailure -> YieldAndContinue replacementChar Done

563 DropOnCodingFailure -> Done

564

565 {-# INLINE_LATE step' #-}

566 step' _ gst (UTF8DecodeInit st) = do

567 r <- step (adaptState gst) st

568 return $ case r of

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

570 Skip s -> Skip (UTF8DecodeInit s)

571 Stop -> Skip Done

572

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

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

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

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

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

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

579 case x > 0x7f of

580 False ->

581 return $ Skip $ YieldAndContinue

582 (unsafeChr (fromIntegral x))

583 (UTF8DecodeInit st)

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

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

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

587 True -> return $ Skip $ UTF8DecodeFirst st x

588

589 -- XXX should we merge it with UTF8DecodeInit1?

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

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

592 return $

593 case sv of

594 12 ->

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

596 in Skip $ handleError msg (UTF8DecodeInit st)

597 0 -> error "unreachable state"

598 _ -> Skip (UTF8Decoding st sv cp)

599

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

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

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

603 r <- step (adaptState gst) st

604 case r of

605 Yield x s -> do

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

607 return $ case sv of

608 0 -> Skip $ YieldAndContinue

609 (unsafeChr cp) (UTF8DecodeInit s)

610 12 ->

611 let msg = prefix

612 ++ "Invalid subsequent UTF8 byte "

613 ++ show x

614 ++ " in state "

615 ++ show statePtr

616 ++ " accumulated value "

617 ++ show codepointPtr

618 in Skip $ handleError msg (UTF8DecodeInit1 s x)

619 _ -> Skip (UTF8Decoding s sv cp)

620 Skip s -> return $

621 Skip (UTF8Decoding s statePtr codepointPtr)

622 Stop -> return $ Skip handleUnderflow

623

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

625 step' _ _ Done = return Stop

626

627{-# INLINE decodeUtf8D #-}

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

629decodeUtf8D = decodeUtf8WithD TransliterateCodingFailure

630

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

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

633-- character.

634--

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

636--

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

638{-# INLINE decodeUtf8 #-}

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

640decodeUtf8 = fromStreamD . decodeUtf8D . toStreamD

641

642{-# INLINE decodeUtf8D' #-}

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

644decodeUtf8D' = decodeUtf8WithD ErrorOnCodingFailure

645

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

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

648--

649-- @since 0.8.0

650{-# INLINE decodeUtf8' #-}

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

652decodeUtf8' = fromStreamD . decodeUtf8D' . toStreamD

653

654{-# INLINE decodeUtf8D_ #-}

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

656decodeUtf8D_ = decodeUtf8WithD DropOnCodingFailure

657

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

659-- Any invalid codepoint encountered is dropped.

660--

661-- @since 0.8.0

662{-# INLINE decodeUtf8_ #-}

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

664decodeUtf8_ = fromStreamD . decodeUtf8D_ . toStreamD

665

666-- | Same as 'decodeUtf8'

667--

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

669{-# INLINE decodeUtf8Lax #-}

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

671decodeUtf8Lax = decodeUtf8

672

673-------------------------------------------------------------------------------

674-- Decoding Array Streams

675-------------------------------------------------------------------------------

676

677#ifndef __GHCJS__

678{-# ANN type FlattenState Fuse #-}

679#endif

680data FlattenState s a

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

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

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

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

685 !DecodeState !CodePoint

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

687 -- encoded in the UTF8DecodeState

688 -- type, I prefer to keep these

689 -- flat even though that means

690 -- coming up with new names

691 | D

692

693-- The normal decodeUtf8 above should fuse with flattenArrays

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

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

696--

697-- XXX Add Proper error messages

698{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}

699decodeUtf8ArraysWithD ::

700 MonadIO m

701 => CodingFailureMode

702 -> Stream m (A.Array Word8)

703 -> Stream m Char

704decodeUtf8ArraysWithD cfm (Stream step state) =

705 let A.Array _ ptr _ = utf8d

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

707 where

708 {-# INLINE transliterateOrError #-}

709 transliterateOrError e s =

710 case cfm of

711 ErrorOnCodingFailure -> error e

712 TransliterateCodingFailure -> YAndC replacementChar s

713 DropOnCodingFailure -> s

714 {-# INLINE inputUnderflow #-}

715 inputUnderflow =

716 case cfm of

717 ErrorOnCodingFailure ->

718 error $

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

720 ++ "decodeUtf8ArraysWith: Input Underflow"

721 TransliterateCodingFailure -> YAndC replacementChar D

722 DropOnCodingFailure -> D

723 {-# INLINE_LATE step' #-}

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

725 r <- step (adaptState gst) st

726 return $

727 case r of

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

729 Skip (InnerLoopDecodeInit s arrContents arrStart aEnd)

730 Skip s -> Skip (OuterLoop s Nothing)

731 Stop -> Skip D

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

733 r <- step (adaptState gst) st

734 return $

735 case r of

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

737 Skip (InnerLoopDecoding s arrContents arrStart aEnd ds cp)

738 Skip s -> Skip (OuterLoop s dst)

739 Stop -> Skip inputUnderflow

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

741 | p == end = do

742 liftIO $ touch startf

743 return $ Skip $ OuterLoop st Nothing

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

745 x <- liftIO $ peek p

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

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

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

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

750 -- branch predication.

751 case x > 0x7f of

752 False ->

753 return $ Skip $ YAndC

754 (unsafeChr (fromIntegral x))

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

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

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

758 -- non-ascii case.

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

760

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

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

763 return $

764 case sv of

765 12 ->

766 Skip $

767 transliterateOrError

768 (

769 "Streamly.Internal.Data.Stream.StreamD."

770 ++ "decodeUtf8ArraysWith: Invalid UTF8"

771 ++ " codepoint encountered"

772 )

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

774 0 -> error "unreachable state"

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

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

777 | p == end = do

778 liftIO $ touch startf

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

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

781 x <- liftIO $ peek p

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

783 return $

784 case sv of

785 0 ->

786 Skip $

787 YAndC

788 (unsafeChr cp)

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

790 12 ->

791 Skip $

792 transliterateOrError

793 (

794 "Streamly.Internal.Data.Stream.StreamD."

795 ++ "decodeUtf8ArraysWith: Invalid UTF8"

796 ++ " codepoint encountered"

797 )

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

799 _ ->

800 Skip

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

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

803 step' _ _ D = return Stop

804

805{-# INLINE decodeUtf8ArraysD #-}

806decodeUtf8ArraysD ::

807 MonadIO m

808 => Stream m (A.Array Word8)

809 -> Stream m Char

810decodeUtf8ArraysD = decodeUtf8ArraysWithD TransliterateCodingFailure

811

812-- |

813--

814-- /Pre-release/

815{-# INLINE decodeUtf8Arrays #-}

816decodeUtf8Arrays ::

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

818decodeUtf8Arrays =

819 fromStreamD . decodeUtf8ArraysD . toStreamD

820

821{-# INLINE decodeUtf8ArraysD' #-}

822decodeUtf8ArraysD' ::

823 MonadIO m

824 => Stream m (A.Array Word8)

825 -> Stream m Char

826decodeUtf8ArraysD' = decodeUtf8ArraysWithD ErrorOnCodingFailure

827

828-- |

829--

830-- /Pre-release/

831{-# INLINE decodeUtf8Arrays' #-}

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

833decodeUtf8Arrays' = fromStreamD . decodeUtf8ArraysD' . toStreamD

834

835{-# INLINE decodeUtf8ArraysD_ #-}

836decodeUtf8ArraysD_ ::

837 MonadIO m

838 => Stream m (A.Array Word8)

839 -> Stream m Char

840decodeUtf8ArraysD_ = decodeUtf8ArraysWithD DropOnCodingFailure

841

842-- |

843--

844-- /Pre-release/

845{-# INLINE decodeUtf8Arrays_ #-}

846decodeUtf8Arrays_ ::

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

848decodeUtf8Arrays_ =

849 fromStreamD . decodeUtf8ArraysD_ . toStreamD

850

851-------------------------------------------------------------------------------

852-- Encoding Unicode (UTF-8) Characters

853-------------------------------------------------------------------------------

854

855data WList = WCons !Word8 !WList | WNil

856

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

858

859{-# INLINE ord2 #-}

860ord2 :: Char -> WList

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

862 where

863 n = ord c

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

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

866

867{-# INLINE ord3 #-}

868ord3 :: Char -> WList

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

870 where

871 n = ord c

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

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

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

875

876{-# INLINE ord4 #-}

877ord4 :: Char -> WList

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

879 where

880 n = ord c

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

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

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

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

885

886{-# INLINE_NORMAL readCharUtf8With #-}

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

888readCharUtf8With surr = Unfold step inject

889

890 where

891

892 inject c =

893 return $ case ord c of

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

895 | x <= 0x7FF -> ord2 c

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

897 | otherwise -> ord4 c

898

899 {-# INLINE_LATE step #-}

900 step WNil = return Stop

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

902

903{-# INLINE_NORMAL readCharUtf8' #-}

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

905readCharUtf8' =

906 readCharUtf8With $

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

908

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

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

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

912-- paths (slow path).

913{-# INLINE_NORMAL encodeUtf8D' #-}

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

915encodeUtf8D' = D.unfoldMany readCharUtf8'

916

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

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

919-- function errors out.

920--

921-- @since 0.8.0

922{-# INLINE encodeUtf8' #-}

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

924encodeUtf8' = fromStreamD . encodeUtf8D' . toStreamD

925

926{-# INLINE_NORMAL readCharUtf8 #-}

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

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

929

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

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

932--

933{-# INLINE_NORMAL encodeUtf8D #-}

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

935encodeUtf8D = D.unfoldMany readCharUtf8

936

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

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

939-- Unicode replacement character U+FFFD.

940--

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

942--

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

944{-# INLINE encodeUtf8 #-}

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

946encodeUtf8 = fromStreamD . encodeUtf8D . toStreamD

947

948{-# INLINE_NORMAL readCharUtf8_ #-}

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

950readCharUtf8_ = readCharUtf8With WNil

951

952{-# INLINE_NORMAL encodeUtf8D_ #-}

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

954encodeUtf8D_ = D.unfoldMany readCharUtf8_

955

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

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

958--

959-- @since 0.8.0

960{-# INLINE encodeUtf8_ #-}

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

962encodeUtf8_ = fromStreamD . encodeUtf8D_ . toStreamD

963

964-- | Same as 'encodeUtf8'

965--

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

967{-# INLINE encodeUtf8Lax #-}

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

969encodeUtf8Lax = encodeUtf8

970

971-------------------------------------------------------------------------------

972-- Encode streams of containers

973-------------------------------------------------------------------------------

974

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

976-- Char stream and an encoding function.

977--

978-- /Internal/

979{-# INLINE encodeObject #-}

980encodeObject :: MonadIO m =>

981 (SerialT m Char -> SerialT m Word8)

982 -> Unfold m a Char

983 -> a

984 -> m (Array Word8)

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

986

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

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

989--

990-- /Internal/

991{-# INLINE encodeObjects #-}

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

993 (SerialT m Char -> SerialT m Word8)

994 -> Unfold m a Char

995 -> t m a

996 -> t m (Array Word8)

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

998

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

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

1001--

1002-- @since 0.8.0

1003{-# INLINE encodeStrings #-}

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

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

1006encodeStrings encode = encodeObjects encode Unfold.fromList

1007

1008{-

1009-------------------------------------------------------------------------------

1010-- Utility operations on strings

1011-------------------------------------------------------------------------------

1012

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

1014strip = undefined

1015

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

1017stripTail = undefined

1018-}

1019

1020-- | Remove leading whitespace from a string.

1021--

1022-- > stripHead = S.dropWhile isSpace

1023--

1024-- /Pre-release/

1025{-# INLINE stripHead #-}

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

1027stripHead = S.dropWhile isSpace

1028

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

1030-- and stream the result.

1031--

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

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

1034--

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

1036--

1037-- /Pre-release/

1038{-# INLINE lines #-}

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

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

1041

1042#if !MIN_VERSION_base(4,17,0)

1043foreign import ccall unsafe "u_iswspace"

1044 iswspace :: Int -> Int

1045#endif

1046

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

1048{-# INLINE isSpace #-}

1049isSpace :: Char -> Bool

1050isSpace c

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

1052#if MIN_VERSION_base(4,17,0)

1053 | otherwise = generalCategory c == Space

1054#else

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

1056#endif

1057 where

1058 uc = fromIntegral (ord c) :: Word

1059

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

1061-- and stream the result.

1062--

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

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

1065--

1066-- > words = S.wordsBy isSpace

1067--

1068-- /Pre-release/

1069{-# INLINE words #-}

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

1071words = S.wordsBy isSpace

1072

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

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

1075--

1076-- @

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

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

1079-- @

1080--

1081-- /Pre-release/

1082{-# INLINE unlines #-}

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

1084unlines = S.interposeSuffix '\n'

1085

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

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

1088-- the streams.

1089--

1090-- @

1091-- unwords = Stream.interpose ' '

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

1093-- @

1094--

1095-- /Pre-release/

1096{-# INLINE unwords #-}

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

1098unwords = S.interpose ' '