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

git.iko.soy/streamly

on ef2ea11 help sign in

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

1089 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)

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 MonadThrow 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 UTF8CharDecodeInit = error $ prefix ++ "Not enough input"

498 extract (UTF8CharDecoding _ _) =

499 case cfm of

500 ErrorOnCodingFailure ->

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

502 TransliterateCodingFailure -> return replacementChar

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

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

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

506

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

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

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

510-- supports backtracking.

511{-# INLINE writeCharUtf8' #-}

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

513writeCharUtf8' = ParserD.toFold (parseCharUtf8WithD ErrorOnCodingFailure)

514

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

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

517--

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

519--

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

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

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

523--

524-- This needs to be investigated futher.

525{-# INLINE parseCharUtf8With #-}

526parseCharUtf8With ::

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

528parseCharUtf8With = ParserD.toParserK . parseCharUtf8WithD

529

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

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

532-- that parses a chunk at a time.

533--

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

535-- decodeUtf8Either preserves the performance characterstics.

536--

537{-# INLINE_NORMAL decodeUtf8WithD #-}

538decodeUtf8WithD :: Monad m

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

540decodeUtf8WithD cfm (Stream step state) =

541 let A.Array _ ptr _ = utf8d

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

543

544 where

545

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

547

548 {-# INLINE handleError #-}

549 handleError e s =

550 case cfm of

551 ErrorOnCodingFailure -> error e

552 TransliterateCodingFailure -> YieldAndContinue replacementChar s

553 DropOnCodingFailure -> s

554

555 {-# INLINE handleUnderflow #-}

556 handleUnderflow =

557 case cfm of

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

559 TransliterateCodingFailure -> YieldAndContinue replacementChar Done

560 DropOnCodingFailure -> Done

561

562 {-# INLINE_LATE step' #-}

563 step' _ gst (UTF8DecodeInit st) = do

564 r <- step (adaptState gst) st

565 return $ case r of

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

567 Skip s -> Skip (UTF8DecodeInit s)

568 Stop -> Skip Done

569

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

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

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

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

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

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

576 case x > 0x7f of

577 False ->

578 return $ Skip $ YieldAndContinue

579 (unsafeChr (fromIntegral x))

580 (UTF8DecodeInit st)

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

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

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

584 True -> return $ Skip $ UTF8DecodeFirst st x

585

586 -- XXX should we merge it with UTF8DecodeInit1?

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

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

589 return $

590 case sv of

591 12 ->

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

593 in Skip $ handleError msg (UTF8DecodeInit st)

594 0 -> error "unreachable state"

595 _ -> Skip (UTF8Decoding st sv cp)

596

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

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

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

600 r <- step (adaptState gst) st

601 case r of

602 Yield x s -> do

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

604 return $ case sv of

605 0 -> Skip $ YieldAndContinue

606 (unsafeChr cp) (UTF8DecodeInit s)

607 12 ->

608 let msg = prefix

609 ++ "Invalid subsequent UTF8 byte "

610 ++ show x

611 ++ " in state "

612 ++ show statePtr

613 ++ " accumulated value "

614 ++ show codepointPtr

615 in Skip $ handleError msg (UTF8DecodeInit1 s x)

616 _ -> Skip (UTF8Decoding s sv cp)

617 Skip s -> return $

618 Skip (UTF8Decoding s statePtr codepointPtr)

619 Stop -> return $ Skip handleUnderflow

620

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

622 step' _ _ Done = return Stop

623

624{-# INLINE decodeUtf8D #-}

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

626decodeUtf8D = decodeUtf8WithD TransliterateCodingFailure

627

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

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

630-- character.

631--

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

633--

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

635{-# INLINE decodeUtf8 #-}

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

637decodeUtf8 = fromStreamD . decodeUtf8D . toStreamD

638

639{-# INLINE decodeUtf8D' #-}

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

641decodeUtf8D' = decodeUtf8WithD ErrorOnCodingFailure

642

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

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

645--

646-- @since 0.8.0

647{-# INLINE decodeUtf8' #-}

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

649decodeUtf8' = fromStreamD . decodeUtf8D' . toStreamD

650

651{-# INLINE decodeUtf8D_ #-}

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

653decodeUtf8D_ = decodeUtf8WithD DropOnCodingFailure

654

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

656-- Any invalid codepoint encountered is dropped.

657--

658-- @since 0.8.0

659{-# INLINE decodeUtf8_ #-}

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

661decodeUtf8_ = fromStreamD . decodeUtf8D_ . toStreamD

662

663-- | Same as 'decodeUtf8'

664--

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

666{-# INLINE decodeUtf8Lax #-}

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

668decodeUtf8Lax = decodeUtf8

669

670-------------------------------------------------------------------------------

671-- Decoding Array Streams

672-------------------------------------------------------------------------------

673

674#ifndef __GHCJS__

675{-# ANN type FlattenState Fuse #-}

676#endif

677data FlattenState s a

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

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

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

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

682 !DecodeState !CodePoint

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

684 -- encoded in the UTF8DecodeState

685 -- type, I prefer to keep these

686 -- flat even though that means

687 -- coming up with new names

688 | D

689

690-- The normal decodeUtf8 above should fuse with flattenArrays

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

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

693--

694-- XXX Add Proper error messages

695{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}

696decodeUtf8ArraysWithD ::

697 MonadIO m

698 => CodingFailureMode

699 -> Stream m (A.Array Word8)

700 -> Stream m Char

701decodeUtf8ArraysWithD cfm (Stream step state) =

702 let A.Array _ ptr _ = utf8d

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

704 where

705 {-# INLINE transliterateOrError #-}

706 transliterateOrError e s =

707 case cfm of

708 ErrorOnCodingFailure -> error e

709 TransliterateCodingFailure -> YAndC replacementChar s

710 DropOnCodingFailure -> s

711 {-# INLINE inputUnderflow #-}

712 inputUnderflow =

713 case cfm of

714 ErrorOnCodingFailure ->

715 error $

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

717 ++ "decodeUtf8ArraysWith: Input Underflow"

718 TransliterateCodingFailure -> YAndC replacementChar D

719 DropOnCodingFailure -> D

720 {-# INLINE_LATE step' #-}

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

722 r <- step (adaptState gst) st

723 return $

724 case r of

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

726 Skip (InnerLoopDecodeInit s arrContents arrStart aEnd)

727 Skip s -> Skip (OuterLoop s Nothing)

728 Stop -> Skip D

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

730 r <- step (adaptState gst) st

731 return $

732 case r of

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

734 Skip (InnerLoopDecoding s arrContents arrStart aEnd ds cp)

735 Skip s -> Skip (OuterLoop s dst)

736 Stop -> Skip inputUnderflow

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

738 | p == end = do

739 liftIO $ touch startf

740 return $ Skip $ OuterLoop st Nothing

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

742 x <- liftIO $ peek p

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

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

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

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

747 -- branch predication.

748 case x > 0x7f of

749 False ->

750 return $ Skip $ YAndC

751 (unsafeChr (fromIntegral x))

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

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

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

755 -- non-ascii case.

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

757

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

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

760 return $

761 case sv of

762 12 ->

763 Skip $

764 transliterateOrError

765 (

766 "Streamly.Internal.Data.Stream.StreamD."

767 ++ "decodeUtf8ArraysWith: Invalid UTF8"

768 ++ " codepoint encountered"

769 )

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

771 0 -> error "unreachable state"

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

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

774 | p == end = do

775 liftIO $ touch startf

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

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

778 x <- liftIO $ peek p

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

780 return $

781 case sv of

782 0 ->

783 Skip $

784 YAndC

785 (unsafeChr cp)

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

787 12 ->

788 Skip $

789 transliterateOrError

790 (

791 "Streamly.Internal.Data.Stream.StreamD."

792 ++ "decodeUtf8ArraysWith: Invalid UTF8"

793 ++ " codepoint encountered"

794 )

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

796 _ ->

797 Skip

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

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

800 step' _ _ D = return Stop

801

802{-# INLINE decodeUtf8ArraysD #-}

803decodeUtf8ArraysD ::

804 MonadIO m

805 => Stream m (A.Array Word8)

806 -> Stream m Char

807decodeUtf8ArraysD = decodeUtf8ArraysWithD TransliterateCodingFailure

808

809-- |

810--

811-- /Pre-release/

812{-# INLINE decodeUtf8Arrays #-}

813decodeUtf8Arrays ::

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

815decodeUtf8Arrays =

816 fromStreamD . decodeUtf8ArraysD . toStreamD

817

818{-# INLINE decodeUtf8ArraysD' #-}

819decodeUtf8ArraysD' ::

820 MonadIO m

821 => Stream m (A.Array Word8)

822 -> Stream m Char

823decodeUtf8ArraysD' = decodeUtf8ArraysWithD ErrorOnCodingFailure

824

825-- |

826--

827-- /Pre-release/

828{-# INLINE decodeUtf8Arrays' #-}

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

830decodeUtf8Arrays' = fromStreamD . decodeUtf8ArraysD' . toStreamD

831

832{-# INLINE decodeUtf8ArraysD_ #-}

833decodeUtf8ArraysD_ ::

834 MonadIO m

835 => Stream m (A.Array Word8)

836 -> Stream m Char

837decodeUtf8ArraysD_ = decodeUtf8ArraysWithD DropOnCodingFailure

838

839-- |

840--

841-- /Pre-release/

842{-# INLINE decodeUtf8Arrays_ #-}

843decodeUtf8Arrays_ ::

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

845decodeUtf8Arrays_ =

846 fromStreamD . decodeUtf8ArraysD_ . toStreamD

847

848-------------------------------------------------------------------------------

849-- Encoding Unicode (UTF-8) Characters

850-------------------------------------------------------------------------------

851

852data WList = WCons !Word8 !WList | WNil

853

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

855

856{-# INLINE ord2 #-}

857ord2 :: Char -> WList

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

859 where

860 n = ord c

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

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

863

864{-# INLINE ord3 #-}

865ord3 :: Char -> WList

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

867 where

868 n = ord c

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

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

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

872

873{-# INLINE ord4 #-}

874ord4 :: Char -> WList

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

876 where

877 n = ord c

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

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

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

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

882

883{-# INLINE_NORMAL readCharUtf8With #-}

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

885readCharUtf8With surr = Unfold step inject

886

887 where

888

889 inject c =

890 return $ case ord c of

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

892 | x <= 0x7FF -> ord2 c

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

894 | otherwise -> ord4 c

895

896 {-# INLINE_LATE step #-}

897 step WNil = return Stop

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

899

900{-# INLINE_NORMAL readCharUtf8' #-}

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

902readCharUtf8' =

903 readCharUtf8With $

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

905

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

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

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

909-- paths (slow path).

910{-# INLINE_NORMAL encodeUtf8D' #-}

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

912encodeUtf8D' = D.unfoldMany readCharUtf8'

913

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

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

916-- function errors out.

917--

918-- @since 0.8.0

919{-# INLINE encodeUtf8' #-}

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

921encodeUtf8' = fromStreamD . encodeUtf8D' . toStreamD

922

923{-# INLINE_NORMAL readCharUtf8 #-}

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

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

926

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

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

929--

930{-# INLINE_NORMAL encodeUtf8D #-}

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

932encodeUtf8D = D.unfoldMany readCharUtf8

933

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

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

936-- Unicode replacement character U+FFFD.

937--

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

939--

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

941{-# INLINE encodeUtf8 #-}

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

943encodeUtf8 = fromStreamD . encodeUtf8D . toStreamD

944

945{-# INLINE_NORMAL readCharUtf8_ #-}

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

947readCharUtf8_ = readCharUtf8With WNil

948

949{-# INLINE_NORMAL encodeUtf8D_ #-}

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

951encodeUtf8D_ = D.unfoldMany readCharUtf8_

952

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

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

955--

956-- @since 0.8.0

957{-# INLINE encodeUtf8_ #-}

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

959encodeUtf8_ = fromStreamD . encodeUtf8D_ . toStreamD

960

961-- | Same as 'encodeUtf8'

962--

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

964{-# INLINE encodeUtf8Lax #-}

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

966encodeUtf8Lax = encodeUtf8

967

968-------------------------------------------------------------------------------

969-- Encode streams of containers

970-------------------------------------------------------------------------------

971

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

973-- Char stream and an encoding function.

974--

975-- /Internal/

976{-# INLINE encodeObject #-}

977encodeObject :: MonadIO m =>

978 (SerialT m Char -> SerialT m Word8)

979 -> Unfold m a Char

980 -> a

981 -> m (Array Word8)

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

983

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

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

986--

987-- /Internal/

988{-# INLINE encodeObjects #-}

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

990 (SerialT m Char -> SerialT m Word8)

991 -> Unfold m a Char

992 -> t m a

993 -> t m (Array Word8)

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

995

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

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

998--

999-- @since 0.8.0

1000{-# INLINE encodeStrings #-}

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

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

1003encodeStrings encode = encodeObjects encode Unfold.fromList

1004

1005{-

1006-------------------------------------------------------------------------------

1007-- Utility operations on strings

1008-------------------------------------------------------------------------------

1009

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

1011strip = undefined

1012

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

1014stripTail = undefined

1015-}

1016

1017-- | Remove leading whitespace from a string.

1018--

1019-- > stripHead = S.dropWhile isSpace

1020--

1021-- /Pre-release/

1022{-# INLINE stripHead #-}

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

1024stripHead = S.dropWhile isSpace

1025

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

1027-- and stream the result.

1028--

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

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

1031--

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

1033--

1034-- /Pre-release/

1035{-# INLINE lines #-}

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

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

1038

1039foreign import ccall unsafe "u_iswspace"

1040 iswspace :: Int -> Int

1041

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

1043{-# INLINE isSpace #-}

1044isSpace :: Char -> Bool

1045isSpace c

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

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

1048 where

1049 uc = fromIntegral (ord c) :: Word

1050

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

1052-- and stream the result.

1053--

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

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

1056--

1057-- > words = S.wordsBy isSpace

1058--

1059-- /Pre-release/

1060{-# INLINE words #-}

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

1062words = S.wordsBy isSpace

1063

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

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

1066--

1067-- @

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

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

1070-- @

1071--

1072-- /Pre-release/

1073{-# INLINE unlines #-}

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

1075unlines = S.interposeSuffix '\n'

1076

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

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

1079-- the streams.

1080--

1081-- @

1082-- unwords = Stream.interpose ' '

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

1084-- @

1085--

1086-- /Pre-release/

1087{-# INLINE unwords #-}

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

1089unwords = S.interpose ' '