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

git.iko.soy/streamly

on 64512ce help sign in

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

1110 lines 41 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 (void)

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

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

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

88import Data.Char (chr, ord)

89#if MIN_VERSION_base(4,17,0)

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

91#endif

92import Data.Word (Word8)

93import Foreign.Marshal.Alloc (mallocBytes)

94import Foreign.Storable (Storable(..))

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

96import GHC.Base (assert, unsafeChr)

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

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

99import System.IO.Unsafe (unsafePerformIO)

100import Streamly.Internal.Data.Array.Unboxed (Array)

101import Streamly.Internal.Data.Array.Unboxed.Mut.Type (ArrayContents)

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

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

104 (IsStream, fromStreamD, toStreamD, adapt)

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

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

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

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

109import Streamly.Internal.Data.Unboxed (peekWith)

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

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

112

113import qualified Streamly.Internal.Data.Fold as Fold

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

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

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

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

118import qualified Streamly.Internal.Data.Array.Unboxed as Array

119import qualified Streamly.Internal.Data.Array.Unboxed.Type as A

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

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

122

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

124

125-- $setup

126-- >>> :m

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

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

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

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

131

132-------------------------------------------------------------------------------

133-- Latin1 decoding

134-------------------------------------------------------------------------------

135

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

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

138--

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

140--

141-- @since 0.8.0

142{-# INLINE decodeLatin1 #-}

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

144decodeLatin1 = S.map (unsafeChr . fromIntegral)

145

146-------------------------------------------------------------------------------

147-- Latin1 encoding

148-------------------------------------------------------------------------------

149

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

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

152-- characters beyond 255.

153--

154-- @since 0.8.0

155{-# INLINE encodeLatin1' #-}

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

157encodeLatin1' = S.map convert

158 where

159 convert c =

160 let codepoint = ord c

161 in if codepoint > 255

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

163 "input char codepoint " ++ show codepoint

164 else fromIntegral codepoint

165

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

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

168-- behavior.

169--

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

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

172-- such mapping occurs.

173--

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

175--

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

177{-# INLINE encodeLatin1 #-}

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

179encodeLatin1 = S.map (fromIntegral . ord)

180

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

182--

183-- @since 0.8.0

184{-# INLINE encodeLatin1_ #-}

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

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

187

188-- | Same as 'encodeLatin1'

189--

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

191{-# INLINE encodeLatin1Lax #-}

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

193encodeLatin1Lax = encodeLatin1

194

195-------------------------------------------------------------------------------

196-- UTF-8 decoding

197-------------------------------------------------------------------------------

198

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

200type CodePoint = Int

201type DecodeState = Word8

202

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

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

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

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

207--

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

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

210-- state can be opaque.

211--

212data DecodeError = DecodeError !DecodeState !CodePoint deriving Show

213

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

215

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

217

218decodeTable :: [Word8]

219decodeTable = [

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

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

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

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

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

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

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

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

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

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

230

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

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

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

234 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,

235 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,

236 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,

237 12,36,12,12,12,12,12,12,12,12,12,12

238 ]

239

240{-# INLINE utf8dLength #-}

241utf8dLength :: Int

242utf8dLength = length decodeTable

243

244-- | We do not want to garbage collect this and free the memory, we want to

245-- keep this persistent. We don't know how to do that with GHC without having a

246-- reference in some global structure. So we use a hack, use mallocBytes so

247-- that the GC has no way to free it.

248{-# NOINLINE utf8d #-}

249utf8d :: Ptr Word8

250utf8d = unsafePerformIO $ do

251 let size = utf8dLength

252 p <- liftIO $ mallocBytes size

253 void $ D.fold

254 (Fold.foldlM' (\b a -> poke b a >> return (b `plusPtr` 1)) (return p))

255 (D.fromList decodeTable)

256 return p

257

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

259-- and without touching the foreign ptr.

260{-# INLINE_NORMAL unsafePeekElemOff #-}

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

262unsafePeekElemOff p i =

263 let !x = unsafeInlineIO $ peekElemOff p i

264 in x

265

266-- XXX We can use a fromPtr stream to implement it.

267{-# INLINE showMemory #-}

268showMemory ::

269 forall a. (Show a, Storable a) => Ptr a -> Ptr a -> String

270showMemory cur end

271 | cur < end =

272 let cur1 = cur `plusPtr` sizeOf (undefined :: a)

273 in show (unsafeInlineIO $ peek cur) ++ " " ++ showMemory cur1 end

274showMemory _ _ = ""

275

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

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

278-- call the appropriate decode function.

279--

280-- When the state is 0

281{-# INLINE decode0 #-}

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

283decode0 table byte =

284 let !t = table `unsafePeekElemOff` fromIntegral byte

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

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

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

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

289 (Tuple' state' codep')

290

291 where

292

293 utf8tableEnd = table `plusPtr` 364

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

295 showTable = " table: " ++ showMemory table utf8tableEnd

296

297-- When the state is not 0

298{-# INLINE decode1 #-}

299decode1

300 :: Ptr Word8

301 -> DecodeState

302 -> CodePoint

303 -> Word8

304 -> Tuple' DecodeState CodePoint

305decode1 table state codep byte =

306 -- Remember codep is Int type!

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

308 let !t = table `unsafePeekElemOff` fromIntegral byte

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

310 !state' = table `unsafePeekElemOff`

311 (256 + fromIntegral state + fromIntegral t)

312 in assert (codep' <= 0x10FFFF

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

314 (Tuple' state' codep')

315 where

316

317 utf8tableEnd = table `plusPtr` 364

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

319 showState st cp =

320 " state: " ++ show st ++

321 " codepoint: " ++ show cp ++

322 " table: " ++ showMemory table utf8tableEnd

323

324-------------------------------------------------------------------------------

325-- Resumable UTF-8 decoding

326-------------------------------------------------------------------------------

327

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

329#ifndef __GHCJS__

330{-# ANN type UTF8DecodeState Fuse #-}

331#endif

332data UTF8DecodeState s a

333 = UTF8DecodeInit s

334 | UTF8DecodeInit1 s Word8

335 | UTF8DecodeFirst s Word8

336 | UTF8Decoding s !DecodeState !CodePoint

337 | YieldAndContinue a (UTF8DecodeState s a)

338 | Done

339

340{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}

341resumeDecodeUtf8EitherD

342 :: Monad m

343 => DecodeState

344 -> CodePoint

345 -> Stream m Word8

346 -> Stream m (Either DecodeError Char)

347resumeDecodeUtf8EitherD dst codep (Stream step state) =

348 let stt =

349 if dst == 0

350 then UTF8DecodeInit state

351 else UTF8Decoding state dst codep

352 in Stream (step' utf8d) stt

353 where

354 {-# INLINE_LATE step' #-}

355 step' _ gst (UTF8DecodeInit st) = do

356 r <- step (adaptState gst) st

357 return $ case r of

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

359 Skip s -> Skip (UTF8DecodeInit s)

360 Stop -> Skip Done

361

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

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

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

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

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

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

368 case x > 0x7f of

369 False ->

370 return $ Skip $ YieldAndContinue

371 (Right $ unsafeChr (fromIntegral x))

372 (UTF8DecodeInit st)

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

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

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

376 True -> return $ Skip $ UTF8DecodeFirst st x

377

378 -- XXX should we merge it with UTF8DecodeInit1?

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

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

381 return $

382 case sv of

383 12 ->

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

385 (UTF8DecodeInit st)

386 0 -> error "unreachable state"

387 _ -> Skip (UTF8Decoding st sv cp)

388

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

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

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

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

393 r <- step (adaptState gst) st

394 case r of

395 Yield x s -> do

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

397 return $

398 case sv of

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

400 (UTF8DecodeInit s)

401 12 ->

402 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)

403 (UTF8DecodeInit1 s x)

404 _ -> Skip (UTF8Decoding s sv cp)

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

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

407

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

409 step' _ _ Done = return Stop

410

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

412-- to use as starting state.

413--

414{-# INLINE_NORMAL decodeUtf8EitherD #-}

415decodeUtf8EitherD :: Monad m

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

417decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0

418

419-- |

420--

421-- /Pre-release/

422{-# INLINE decodeUtf8Either #-}

423decodeUtf8Either :: (Monad m, IsStream t)

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

425decodeUtf8Either = fromStreamD . decodeUtf8EitherD . toStreamD

426

427-- |

428--

429-- /Pre-release/

430{-# INLINE resumeDecodeUtf8Either #-}

431resumeDecodeUtf8Either

432 :: (Monad m, IsStream t)

433 => DecodeState

434 -> CodePoint

435 -> t m Word8

436 -> t m (Either DecodeError Char)

437resumeDecodeUtf8Either st cp =

438 fromStreamD . resumeDecodeUtf8EitherD st cp . toStreamD

439

440-------------------------------------------------------------------------------

441-- One shot decoding

442-------------------------------------------------------------------------------

443

444data CodingFailureMode

445 = TransliterateCodingFailure

446 | ErrorOnCodingFailure

447 | DropOnCodingFailure

448 deriving (Show)

449

450{-# INLINE replacementChar #-}

451replacementChar :: Char

452replacementChar = '\xFFFD'

453

454data UTF8CharDecodeState a

455 = UTF8CharDecodeInit

456 | UTF8CharDecoding !DecodeState !CodePoint

457

458{-# INLINE parseCharUtf8WithD #-}

459parseCharUtf8WithD ::

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

461parseCharUtf8WithD cfm = ParserD.Parser (step' utf8d) initial extract

462

463 where

464

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

466

467 {-# INLINE initial #-}

468 initial = return $ ParserD.IPartial UTF8CharDecodeInit

469

470 handleError err souldBackTrack =

471 case cfm of

472 ErrorOnCodingFailure -> ParserD.Error err

473 TransliterateCodingFailure ->

474 case souldBackTrack of

475 True -> ParserD.Done 1 replacementChar

476 False -> ParserD.Done 0 replacementChar

477 DropOnCodingFailure ->

478 case souldBackTrack of

479 True -> ParserD.Continue 1 UTF8CharDecodeInit

480 False -> ParserD.Continue 0 UTF8CharDecodeInit

481

482 {-# INLINE step' #-}

483 step' table UTF8CharDecodeInit x =

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

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

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

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

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

489 return $ case x > 0x7f of

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

491 True ->

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

493 in case sv of

494 12 ->

495 let msg = prefix

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

497 in handleError msg False

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

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

500

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

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

503 in case sv of

504 0 -> ParserD.Done 0 $ unsafeChr cp

505 12 ->

506 let msg = prefix

507 ++ "Invalid subsequent UTF8 byte"

508 ++ show x

509 ++ "in state"

510 ++ show statePtr

511 ++ "accumulated value"

512 ++ show codepointPtr

513 in handleError msg True

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

515

516 {-# INLINE extract #-}

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

518 extract (UTF8CharDecoding _ _) =

519 case cfm of

520 ErrorOnCodingFailure ->

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

522 TransliterateCodingFailure -> return replacementChar

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

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

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

526

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

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

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

530-- supports backtracking.

531{-# INLINE writeCharUtf8' #-}

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

533writeCharUtf8' = ParserD.toFold (parseCharUtf8WithD ErrorOnCodingFailure)

534

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

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

537--

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

539--

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

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

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

543--

544-- This needs to be investigated futher.

545{-# INLINE parseCharUtf8With #-}

546parseCharUtf8With ::

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

548parseCharUtf8With = ParserD.toParserK . parseCharUtf8WithD

549

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

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

552-- that parses a chunk at a time.

553--

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

555-- decodeUtf8Either preserves the performance characterstics.

556--

557{-# INLINE_NORMAL decodeUtf8WithD #-}

558decodeUtf8WithD :: Monad m

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

560decodeUtf8WithD cfm (Stream step state) =

561 Stream (step' utf8d) (UTF8DecodeInit state)

562

563 where

564

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

566

567 {-# INLINE handleError #-}

568 handleError e s =

569 case cfm of

570 ErrorOnCodingFailure -> error e

571 TransliterateCodingFailure -> YieldAndContinue replacementChar s

572 DropOnCodingFailure -> s

573

574 {-# INLINE handleUnderflow #-}

575 handleUnderflow =

576 case cfm of

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

578 TransliterateCodingFailure -> YieldAndContinue replacementChar Done

579 DropOnCodingFailure -> Done

580

581 {-# INLINE_LATE step' #-}

582 step' _ gst (UTF8DecodeInit st) = do

583 r <- step (adaptState gst) st

584 return $ case r of

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

586 Skip s -> Skip (UTF8DecodeInit s)

587 Stop -> Skip Done

588

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

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

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

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

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

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

595 case x > 0x7f of

596 False ->

597 return $ Skip $ YieldAndContinue

598 (unsafeChr (fromIntegral x))

599 (UTF8DecodeInit st)

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

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

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

603 True -> return $ Skip $ UTF8DecodeFirst st x

604

605 -- XXX should we merge it with UTF8DecodeInit1?

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

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

608 return $

609 case sv of

610 12 ->

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

612 in Skip $ handleError msg (UTF8DecodeInit st)

613 0 -> error "unreachable state"

614 _ -> Skip (UTF8Decoding st sv cp)

615

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

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

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

619 r <- step (adaptState gst) st

620 case r of

621 Yield x s -> do

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

623 return $ case sv of

624 0 -> Skip $ YieldAndContinue

625 (unsafeChr cp) (UTF8DecodeInit s)

626 12 ->

627 let msg = prefix

628 ++ "Invalid subsequent UTF8 byte "

629 ++ show x

630 ++ " in state "

631 ++ show statePtr

632 ++ " accumulated value "

633 ++ show codepointPtr

634 in Skip $ handleError msg (UTF8DecodeInit1 s x)

635 _ -> Skip (UTF8Decoding s sv cp)

636 Skip s -> return $

637 Skip (UTF8Decoding s statePtr codepointPtr)

638 Stop -> return $ Skip handleUnderflow

639

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

641 step' _ _ Done = return Stop

642

643{-# INLINE decodeUtf8D #-}

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

645decodeUtf8D = decodeUtf8WithD TransliterateCodingFailure

646

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

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

649-- character.

650--

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

652--

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

654{-# INLINE decodeUtf8 #-}

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

656decodeUtf8 = fromStreamD . decodeUtf8D . toStreamD

657

658{-# INLINE decodeUtf8D' #-}

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

660decodeUtf8D' = decodeUtf8WithD ErrorOnCodingFailure

661

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

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

664--

665-- @since 0.8.0

666{-# INLINE decodeUtf8' #-}

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

668decodeUtf8' = fromStreamD . decodeUtf8D' . toStreamD

669

670{-# INLINE decodeUtf8D_ #-}

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

672decodeUtf8D_ = decodeUtf8WithD DropOnCodingFailure

673

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

675-- Any invalid codepoint encountered is dropped.

676--

677-- @since 0.8.0

678{-# INLINE decodeUtf8_ #-}

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

680decodeUtf8_ = fromStreamD . decodeUtf8D_ . toStreamD

681

682-- | Same as 'decodeUtf8'

683--

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

685{-# INLINE decodeUtf8Lax #-}

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

687decodeUtf8Lax = decodeUtf8

688

689-------------------------------------------------------------------------------

690-- Decoding Array Streams

691-------------------------------------------------------------------------------

692

693#ifndef __GHCJS__

694{-# ANN type FlattenState Fuse #-}

695#endif

696data FlattenState s a

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

698 | InnerLoopDecodeInit s (ArrayContents a) !Int !Int

699 | InnerLoopDecodeFirst s (ArrayContents a) !Int !Int Word8

700 | InnerLoopDecoding s (ArrayContents a) !Int !Int

701 !DecodeState !CodePoint

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

703 -- encoded in the UTF8DecodeState

704 -- type, I prefer to keep these

705 -- flat even though that means

706 -- coming up with new names

707 | D

708

709-- The normal decodeUtf8 above should fuse with flattenArrays

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

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

712--

713-- XXX Add Proper error messages

714{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}

715decodeUtf8ArraysWithD ::

716 MonadIO m

717 => CodingFailureMode

718 -> Stream m (A.Array Word8)

719 -> Stream m Char

720decodeUtf8ArraysWithD cfm (Stream step state) =

721 Stream (step' utf8d) (OuterLoop state Nothing)

722 where

723 {-# INLINE transliterateOrError #-}

724 transliterateOrError e s =

725 case cfm of

726 ErrorOnCodingFailure -> error e

727 TransliterateCodingFailure -> YAndC replacementChar s

728 DropOnCodingFailure -> s

729 {-# INLINE inputUnderflow #-}

730 inputUnderflow =

731 case cfm of

732 ErrorOnCodingFailure ->

733 error $

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

735 ++ "decodeUtf8ArraysWith: Input Underflow"

736 TransliterateCodingFailure -> YAndC replacementChar D

737 DropOnCodingFailure -> D

738 {-# INLINE_LATE step' #-}

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

740 r <- step (adaptState gst) st

741 return $

742 case r of

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

744 Skip (InnerLoopDecodeInit s arrContents arrStart aEnd)

745 Skip s -> Skip (OuterLoop s Nothing)

746 Stop -> Skip D

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

748 r <- step (adaptState gst) st

749 return $

750 case r of

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

752 Skip (InnerLoopDecoding s arrContents arrStart aEnd ds cp)

753 Skip s -> Skip (OuterLoop s dst)

754 Stop -> Skip inputUnderflow

755 step' _ _ (InnerLoopDecodeInit st _ p end)

756 | p == end = do

757 return $ Skip $ OuterLoop st Nothing

758 step' _ _ (InnerLoopDecodeInit st contents p end) = do

759 x <- liftIO $ peekWith contents p

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

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

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

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

764 -- branch predication.

765 case x > 0x7f of

766 False ->

767 return $ Skip $ YAndC

768 (unsafeChr (fromIntegral x))

769 (InnerLoopDecodeInit st contents (p + 1) end)

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

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

772 -- non-ascii case.

773 True -> return $ Skip $ InnerLoopDecodeFirst st contents p end x

774

775 step' table _ (InnerLoopDecodeFirst st contents p end x) = do

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

777 return $

778 case sv of

779 12 ->

780 Skip $

781 transliterateOrError

782 (

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

784 ++ "decodeUtf8ArraysWith: Invalid UTF8"

785 ++ " codepoint encountered"

786 )

787 (InnerLoopDecodeInit st contents (p + 1) end)

788 0 -> error "unreachable state"

789 _ -> Skip (InnerLoopDecoding st contents (p + 1) end sv cp)

790 step' _ _ (InnerLoopDecoding st _ p end sv cp)

791 | p == end = return $ Skip $ OuterLoop st (Just (sv, cp))

792 step' table _ (InnerLoopDecoding st contents p end statePtr codepointPtr) = do

793 x <- liftIO $ peekWith contents p

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

795 return $

796 case sv of

797 0 ->

798 Skip $

799 YAndC

800 (unsafeChr cp)

801 (InnerLoopDecodeInit st contents (p + 1) end)

802 12 ->

803 Skip $

804 transliterateOrError

805 (

806 "Streamly.Internal.Data.Stream.StreamD."

807 ++ "decodeUtf8ArraysWith: Invalid UTF8"

808 ++ " codepoint encountered"

809 )

810 (InnerLoopDecodeInit st contents (p + 1) end)

811 _ ->

812 Skip

813 (InnerLoopDecoding st contents (p + 1) end sv cp)

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

815 step' _ _ D = return Stop

816

817{-# INLINE decodeUtf8ArraysD #-}

818decodeUtf8ArraysD ::

819 MonadIO m

820 => Stream m (A.Array Word8)

821 -> Stream m Char

822decodeUtf8ArraysD = decodeUtf8ArraysWithD TransliterateCodingFailure

823

824-- |

825--

826-- /Pre-release/

827{-# INLINE decodeUtf8Arrays #-}

828decodeUtf8Arrays ::

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

830decodeUtf8Arrays =

831 fromStreamD . decodeUtf8ArraysD . toStreamD

832

833{-# INLINE decodeUtf8ArraysD' #-}

834decodeUtf8ArraysD' ::

835 MonadIO m

836 => Stream m (A.Array Word8)

837 -> Stream m Char

838decodeUtf8ArraysD' = decodeUtf8ArraysWithD ErrorOnCodingFailure

839

840-- |

841--

842-- /Pre-release/

843{-# INLINE decodeUtf8Arrays' #-}

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

845decodeUtf8Arrays' = fromStreamD . decodeUtf8ArraysD' . toStreamD

846

847{-# INLINE decodeUtf8ArraysD_ #-}

848decodeUtf8ArraysD_ ::

849 MonadIO m

850 => Stream m (A.Array Word8)

851 -> Stream m Char

852decodeUtf8ArraysD_ = decodeUtf8ArraysWithD DropOnCodingFailure

853

854-- |

855--

856-- /Pre-release/

857{-# INLINE decodeUtf8Arrays_ #-}

858decodeUtf8Arrays_ ::

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

860decodeUtf8Arrays_ =

861 fromStreamD . decodeUtf8ArraysD_ . toStreamD

862

863-------------------------------------------------------------------------------

864-- Encoding Unicode (UTF-8) Characters

865-------------------------------------------------------------------------------

866

867data WList = WCons !Word8 !WList | WNil

868

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

870

871{-# INLINE ord2 #-}

872ord2 :: Char -> WList

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

874 where

875 n = ord c

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

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

878

879{-# INLINE ord3 #-}

880ord3 :: Char -> WList

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

882 where

883 n = ord c

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

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

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

887

888{-# INLINE ord4 #-}

889ord4 :: Char -> WList

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

891 where

892 n = ord c

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

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

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

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

897

898{-# INLINE_NORMAL readCharUtf8With #-}

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

900readCharUtf8With surr = Unfold step inject

901

902 where

903

904 inject c =

905 return $ case ord c of

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

907 | x <= 0x7FF -> ord2 c

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

909 | otherwise -> ord4 c

910

911 {-# INLINE_LATE step #-}

912 step WNil = return Stop

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

914

915{-# INLINE_NORMAL readCharUtf8' #-}

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

917readCharUtf8' =

918 readCharUtf8With $

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

920

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

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

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

924-- paths (slow path).

925{-# INLINE_NORMAL encodeUtf8D' #-}

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

927encodeUtf8D' = D.unfoldMany readCharUtf8'

928

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

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

931-- function errors out.

932--

933-- @since 0.8.0

934{-# INLINE encodeUtf8' #-}

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

936encodeUtf8' = fromStreamD . encodeUtf8D' . toStreamD

937

938{-# INLINE_NORMAL readCharUtf8 #-}

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

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

941

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

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

944--

945{-# INLINE_NORMAL encodeUtf8D #-}

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

947encodeUtf8D = D.unfoldMany readCharUtf8

948

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

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

951-- Unicode replacement character U+FFFD.

952--

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

954--

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

956{-# INLINE encodeUtf8 #-}

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

958encodeUtf8 = fromStreamD . encodeUtf8D . toStreamD

959

960{-# INLINE_NORMAL readCharUtf8_ #-}

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

962readCharUtf8_ = readCharUtf8With WNil

963

964{-# INLINE_NORMAL encodeUtf8D_ #-}

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

966encodeUtf8D_ = D.unfoldMany readCharUtf8_

967

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

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

970--

971-- @since 0.8.0

972{-# INLINE encodeUtf8_ #-}

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

974encodeUtf8_ = fromStreamD . encodeUtf8D_ . toStreamD

975

976-- | Same as 'encodeUtf8'

977--

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

979{-# INLINE encodeUtf8Lax #-}

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

981encodeUtf8Lax = encodeUtf8

982

983-------------------------------------------------------------------------------

984-- Encode streams of containers

985-------------------------------------------------------------------------------

986

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

988-- Char stream and an encoding function.

989--

990-- /Internal/

991{-# INLINE encodeObject #-}

992encodeObject :: MonadIO m =>

993 (SerialT m Char -> SerialT m Word8)

994 -> Unfold m a Char

995 -> a

996 -> m (Array Word8)

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

998

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

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

1001--

1002-- /Internal/

1003{-# INLINE encodeObjects #-}

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

1005 (SerialT m Char -> SerialT m Word8)

1006 -> Unfold m a Char

1007 -> t m a

1008 -> t m (Array Word8)

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

1010

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

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

1013--

1014-- @since 0.8.0

1015{-# INLINE encodeStrings #-}

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

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

1018encodeStrings encode = encodeObjects encode Unfold.fromList

1019

1020{-

1021-------------------------------------------------------------------------------

1022-- Utility operations on strings

1023-------------------------------------------------------------------------------

1024

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

1026strip = undefined

1027

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

1029stripTail = undefined

1030-}

1031

1032-- | Remove leading whitespace from a string.

1033--

1034-- > stripHead = S.dropWhile isSpace

1035--

1036-- /Pre-release/

1037{-# INLINE stripHead #-}

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

1039stripHead = S.dropWhile isSpace

1040

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

1042-- and stream the result.

1043--

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

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

1046--

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

1048--

1049-- /Pre-release/

1050{-# INLINE lines #-}

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

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

1053

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

1055foreign import ccall unsafe "u_iswspace"

1056 iswspace :: Int -> Int

1057#endif

1058

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

1060{-# INLINE isSpace #-}

1061isSpace :: Char -> Bool

1062isSpace c

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

1064#if MIN_VERSION_base(4,17,0)

1065 | otherwise = generalCategory c == Space

1066#else

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

1068#endif

1069 where

1070 uc = fromIntegral (ord c) :: Word

1071

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

1073-- and stream the result.

1074--

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

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

1077--

1078-- > words = S.wordsBy isSpace

1079--

1080-- /Pre-release/

1081{-# INLINE words #-}

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

1083words = S.wordsBy isSpace

1084

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

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

1087--

1088-- @

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

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

1091-- @

1092--

1093-- /Pre-release/

1094{-# INLINE unlines #-}

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

1096unlines = S.interposeSuffix '\n'

1097

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

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

1100-- the streams.

1101--

1102-- @

1103-- unwords = Stream.interpose ' '

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

1105-- @

1106--

1107-- /Pre-release/

1108{-# INLINE unwords #-}

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

1110unwords = S.interpose ' '