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

git.iko.soy/streamly

on e3e60ca help sign in

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

1137 lines 42 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 -- * Decoding String Literals

76 , fromStr#

78 -- * Deprecations

79 , decodeUtf8Lax

80 , encodeLatin1Lax

81 , encodeUtf8Lax

82 )

83where

85#include "inline.hs"

87import Control.Monad (void)

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

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

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

91import Data.Char (chr, ord)

92#if MIN_VERSION_base(4,17,0)

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

94#endif

95import Data.Word (Word8)

96import Foreign.Marshal.Alloc (mallocBytes)

97import Foreign.Storable (Storable(..))

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

99import GHC.Base (assert, unsafeChr)

100import GHC.Exts (Addr#)

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

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

103import System.IO.Unsafe (unsafePerformIO)

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

105import Streamly.Internal.Data.Array.Unboxed.Mut.Type (MutableByteArray)

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

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

108 (IsStream, fromStreamD, toStreamD, adapt)

109import Streamly.Internal.Data.Stream (Stream)

110import Streamly.Internal.Data.Stream.StreamD (Step (..))

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

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

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

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

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

116

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

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

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

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

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

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

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

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

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

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

127

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

129

130-- $setup

131-- >>> :m

132-- >>> :set -XMagicHash

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

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

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

136-- >>> import qualified Streamly.Internal.Unicode.Stream as Unicode

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

138

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

140-- Latin1 decoding

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

142

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

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

145--

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

147--

148-- @since 0.8.0

149{-# INLINE decodeLatin1 #-}

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

151decodeLatin1 = S.map (unsafeChr . fromIntegral)

152

153-------------------------------------------------------------------------------

154-- Latin1 encoding

155-------------------------------------------------------------------------------

156

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

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

159-- characters beyond 255.

160--

161-- @since 0.8.0

162{-# INLINE encodeLatin1' #-}

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

164encodeLatin1' = S.map convert

165 where

166 convert c =

167 let codepoint = ord c

168 in if codepoint > 255

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

170 "input char codepoint " ++ show codepoint

171 else fromIntegral codepoint

172

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

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

175-- behavior.

176--

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

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

179-- such mapping occurs.

180--

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

182--

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

184{-# INLINE encodeLatin1 #-}

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

186encodeLatin1 = S.map (fromIntegral . ord)

187

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

189--

190-- @since 0.8.0

191{-# INLINE encodeLatin1_ #-}

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

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

194

195-- | Same as 'encodeLatin1'

196--

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

198{-# INLINE encodeLatin1Lax #-}

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

200encodeLatin1Lax = encodeLatin1

201

202-------------------------------------------------------------------------------

203-- UTF-8 decoding

204-------------------------------------------------------------------------------

205

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

207type CodePoint = Int

208type DecodeState = Word8

209

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

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

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

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

214--

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

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

217-- state can be opaque.

218--

219data DecodeError = DecodeError !DecodeState !CodePoint deriving Show

220

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

222

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

224

225decodeTable :: [Word8]

226decodeTable = [

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

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

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

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

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

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

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

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

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

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

237

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

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

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

241 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,

242 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,

243 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,

244 12,36,12,12,12,12,12,12,12,12,12,12

245 ]

246

247{-# INLINE utf8dLength #-}

248utf8dLength :: Int

249utf8dLength = length decodeTable

250

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

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

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

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

255{-# NOINLINE utf8d #-}

256utf8d :: Ptr Word8

257utf8d = unsafePerformIO $ do

258 let size = utf8dLength

259 p <- liftIO $ mallocBytes size

260 void $ D.fold

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

262 (D.fromList decodeTable)

263 return p

264

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

266-- and without touching the foreign ptr.

267{-# INLINE_NORMAL unsafePeekElemOff #-}

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

269unsafePeekElemOff p i =

270 let !x = unsafeInlineIO $ peekElemOff p i

271 in x

272

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

274{-# INLINE showMemory #-}

275showMemory ::

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

277showMemory cur end

278 | cur < end =

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

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

281showMemory _ _ = ""

282

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

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

285-- call the appropriate decode function.

286--

287-- When the state is 0

288{-# INLINE decode0 #-}

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

290decode0 table byte =

291 let !t = table `unsafePeekElemOff` fromIntegral byte

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

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

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

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

296 (Tuple' state' codep')

297

298 where

299

300 utf8tableEnd = table `plusPtr` 364

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

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

303

304-- When the state is not 0

305{-# INLINE decode1 #-}

306decode1

307 :: Ptr Word8

308 -> DecodeState

309 -> CodePoint

310 -> Word8

311 -> Tuple' DecodeState CodePoint

312decode1 table state codep byte =

313 -- Remember codep is Int type!

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

315 let !t = table `unsafePeekElemOff` fromIntegral byte

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

317 !state' = table `unsafePeekElemOff`

318 (256 + fromIntegral state + fromIntegral t)

319 in assert (codep' <= 0x10FFFF

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

321 (Tuple' state' codep')

322 where

323

324 utf8tableEnd = table `plusPtr` 364

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

326 showState st cp =

327 " state: " ++ show st ++

328 " codepoint: " ++ show cp ++

329 " table: " ++ showMemory table utf8tableEnd

330

331-------------------------------------------------------------------------------

332-- Resumable UTF-8 decoding

333-------------------------------------------------------------------------------

334

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

336#ifndef __GHCJS__

337{-# ANN type UTF8DecodeState Fuse #-}

338#endif

339data UTF8DecodeState s a

340 = UTF8DecodeInit s

341 | UTF8DecodeInit1 s Word8

342 | UTF8DecodeFirst s Word8

343 | UTF8Decoding s !DecodeState !CodePoint

344 | YieldAndContinue a (UTF8DecodeState s a)

345 | Done

346

347{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}

348resumeDecodeUtf8EitherD

349 :: Monad m

350 => DecodeState

351 -> CodePoint

352 -> D.Stream m Word8

353 -> D.Stream m (Either DecodeError Char)

354resumeDecodeUtf8EitherD dst codep (D.Stream step state) =

355 let stt =

356 if dst == 0

357 then UTF8DecodeInit state

358 else UTF8Decoding state dst codep

359 in D.Stream (step' utf8d) stt

360 where

361 {-# INLINE_LATE step' #-}

362 step' _ gst (UTF8DecodeInit st) = do

363 r <- step (adaptState gst) st

364 return $ case r of

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

366 Skip s -> Skip (UTF8DecodeInit s)

367 Stop -> Skip Done

368

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

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

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

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

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

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

375 case x > 0x7f of

376 False ->

377 return $ Skip $ YieldAndContinue

378 (Right $ unsafeChr (fromIntegral x))

379 (UTF8DecodeInit st)

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

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

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

383 True -> return $ Skip $ UTF8DecodeFirst st x

384

385 -- XXX should we merge it with UTF8DecodeInit1?

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

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

388 return $

389 case sv of

390 12 ->

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

392 (UTF8DecodeInit st)

393 0 -> error "unreachable state"

394 _ -> Skip (UTF8Decoding st sv cp)

395

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

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

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

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

400 r <- step (adaptState gst) st

401 case r of

402 Yield x s -> do

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

404 return $

405 case sv of

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

407 (UTF8DecodeInit s)

408 12 ->

409 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)

410 (UTF8DecodeInit1 s x)

411 _ -> Skip (UTF8Decoding s sv cp)

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

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

414

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

416 step' _ _ Done = return Stop

417

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

419-- to use as starting state.

420--

421{-# INLINE_NORMAL decodeUtf8EitherD #-}

422decodeUtf8EitherD :: Monad m

423 => D.Stream m Word8 -> D.Stream m (Either DecodeError Char)

424decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0

425

426-- |

427--

428-- /Pre-release/

429{-# INLINE decodeUtf8Either #-}

430decodeUtf8Either :: (Monad m, IsStream t)

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

432decodeUtf8Either = fromStreamD . decodeUtf8EitherD . toStreamD

433

434-- |

435--

436-- /Pre-release/

437{-# INLINE resumeDecodeUtf8Either #-}

438resumeDecodeUtf8Either

439 :: (Monad m, IsStream t)

440 => DecodeState

441 -> CodePoint

442 -> t m Word8

443 -> t m (Either DecodeError Char)

444resumeDecodeUtf8Either st cp =

445 fromStreamD . resumeDecodeUtf8EitherD st cp . toStreamD

446

447-------------------------------------------------------------------------------

448-- One shot decoding

449-------------------------------------------------------------------------------

450

451data CodingFailureMode

452 = TransliterateCodingFailure

453 | ErrorOnCodingFailure

454 | DropOnCodingFailure

455 deriving (Show)

456

457{-# INLINE replacementChar #-}

458replacementChar :: Char

459replacementChar = '\xFFFD'

460

461data UTF8CharDecodeState a

462 = UTF8CharDecodeInit

463 | UTF8CharDecoding !DecodeState !CodePoint

464

465{-# INLINE parseCharUtf8WithD #-}

466parseCharUtf8WithD ::

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

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

469

470 where

471

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

473

474 {-# INLINE initial #-}

475 initial = return $ ParserD.IPartial UTF8CharDecodeInit

476

477 handleError err souldBackTrack =

478 case cfm of

479 ErrorOnCodingFailure -> ParserD.Error err

480 TransliterateCodingFailure ->

481 case souldBackTrack of

482 True -> ParserD.Done 1 replacementChar

483 False -> ParserD.Done 0 replacementChar

484 DropOnCodingFailure ->

485 case souldBackTrack of

486 True -> ParserD.Continue 1 UTF8CharDecodeInit

487 False -> ParserD.Continue 0 UTF8CharDecodeInit

488

489 {-# INLINE step' #-}

490 step' table UTF8CharDecodeInit x =

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

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

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

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

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

496 return $ case x > 0x7f of

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

498 True ->

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

500 in case sv of

501 12 ->

502 let msg = prefix

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

504 in handleError msg False

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

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

507

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

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

510 in case sv of

511 0 -> ParserD.Done 0 $ unsafeChr cp

512 12 ->

513 let msg = prefix

514 ++ "Invalid subsequent UTF8 byte"

515 ++ show x

516 ++ "in state"

517 ++ show statePtr

518 ++ "accumulated value"

519 ++ show codepointPtr

520 in handleError msg True

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

522

523 {-# INLINE extract #-}

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

525 extract (UTF8CharDecoding _ _) =

526 case cfm of

527 ErrorOnCodingFailure ->

528 return $ ParserD.Error $ prefix ++ "Not enough input"

529 TransliterateCodingFailure ->

530 return (ParserD.Done 0 replacementChar)

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

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

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

534

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

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

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

538-- supports backtracking.

539{-# INLINE writeCharUtf8' #-}

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

541writeCharUtf8' = ParserD.toFold (parseCharUtf8WithD ErrorOnCodingFailure)

542

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

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

545--

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

547--

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

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

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

551--

552-- This needs to be investigated futher.

553{-# INLINE parseCharUtf8With #-}

554parseCharUtf8With ::

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

556parseCharUtf8With = ParserD.toParserK . parseCharUtf8WithD

557

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

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

560-- that parses a chunk at a time.

561--

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

563-- decodeUtf8Either preserves the performance characterstics.

564--

565{-# INLINE_NORMAL decodeUtf8WithD #-}

566decodeUtf8WithD :: Monad m

567 => CodingFailureMode -> D.Stream m Word8 -> D.Stream m Char

568decodeUtf8WithD cfm (D.Stream step state) =

569 D.Stream (step' utf8d) (UTF8DecodeInit state)

570

571 where

572

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

574

575 {-# INLINE handleError #-}

576 handleError e s =

577 case cfm of

578 ErrorOnCodingFailure -> error e

579 TransliterateCodingFailure -> YieldAndContinue replacementChar s

580 DropOnCodingFailure -> s

581

582 {-# INLINE handleUnderflow #-}

583 handleUnderflow =

584 case cfm of

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

586 TransliterateCodingFailure -> YieldAndContinue replacementChar Done

587 DropOnCodingFailure -> Done

588

589 {-# INLINE_LATE step' #-}

590 step' _ gst (UTF8DecodeInit st) = do

591 r <- step (adaptState gst) st

592 return $ case r of

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

594 Skip s -> Skip (UTF8DecodeInit s)

595 Stop -> Skip Done

596

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

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

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

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

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

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

603 case x > 0x7f of

604 False ->

605 return $ Skip $ YieldAndContinue

606 (unsafeChr (fromIntegral x))

607 (UTF8DecodeInit st)

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

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

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

611 True -> return $ Skip $ UTF8DecodeFirst st x

612

613 -- XXX should we merge it with UTF8DecodeInit1?

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

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

616 return $

617 case sv of

618 12 ->

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

620 in Skip $ handleError msg (UTF8DecodeInit st)

621 0 -> error "unreachable state"

622 _ -> Skip (UTF8Decoding st sv cp)

623

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

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

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

627 r <- step (adaptState gst) st

628 case r of

629 Yield x s -> do

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

631 return $ case sv of

632 0 -> Skip $ YieldAndContinue

633 (unsafeChr cp) (UTF8DecodeInit s)

634 12 ->

635 let msg = prefix

636 ++ "Invalid subsequent UTF8 byte "

637 ++ show x

638 ++ " in state "

639 ++ show statePtr

640 ++ " accumulated value "

641 ++ show codepointPtr

642 in Skip $ handleError msg (UTF8DecodeInit1 s x)

643 _ -> Skip (UTF8Decoding s sv cp)

644 Skip s -> return $

645 Skip (UTF8Decoding s statePtr codepointPtr)

646 Stop -> return $ Skip handleUnderflow

647

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

649 step' _ _ Done = return Stop

650

651{-# INLINE decodeUtf8D #-}

652decodeUtf8D :: Monad m => D.Stream m Word8 -> D.Stream m Char

653decodeUtf8D = decodeUtf8WithD TransliterateCodingFailure

654

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

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

657-- character.

658--

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

660--

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

662{-# INLINE decodeUtf8 #-}

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

664decodeUtf8 = fromStreamD . decodeUtf8D . toStreamD

665

666{-# INLINE decodeUtf8D' #-}

667decodeUtf8D' :: Monad m => D.Stream m Word8 -> D.Stream m Char

668decodeUtf8D' = decodeUtf8WithD ErrorOnCodingFailure

669

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

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

672--

673-- @since 0.8.0

674{-# INLINE decodeUtf8' #-}

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

676decodeUtf8' = fromStreamD . decodeUtf8D' . toStreamD

677

678{-# INLINE decodeUtf8D_ #-}

679decodeUtf8D_ :: Monad m => D.Stream m Word8 -> D.Stream m Char

680decodeUtf8D_ = decodeUtf8WithD DropOnCodingFailure

681

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

683-- Any invalid codepoint encountered is dropped.

684--

685-- @since 0.8.0

686{-# INLINE decodeUtf8_ #-}

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

688decodeUtf8_ = fromStreamD . decodeUtf8D_ . toStreamD

689

690-- | Same as 'decodeUtf8'

691--

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

693{-# INLINE decodeUtf8Lax #-}

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

695decodeUtf8Lax = decodeUtf8

696

697-------------------------------------------------------------------------------

698-- Decoding Array Streams

699-------------------------------------------------------------------------------

700

701#ifndef __GHCJS__

702{-# ANN type FlattenState Fuse #-}

703#endif

704data FlattenState s a

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

706 | InnerLoopDecodeInit s (MutableByteArray a) !Int !Int

707 | InnerLoopDecodeFirst s (MutableByteArray a) !Int !Int Word8

708 | InnerLoopDecoding s (MutableByteArray a) !Int !Int

709 !DecodeState !CodePoint

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

711 -- encoded in the UTF8DecodeState

712 -- type, I prefer to keep these

713 -- flat even though that means

714 -- coming up with new names

715 | D

716

717-- The normal decodeUtf8 above should fuse with flattenArrays

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

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

720--

721-- XXX Add Proper error messages

722{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}

723decodeUtf8ArraysWithD ::

724 MonadIO m

725 => CodingFailureMode

726 -> D.Stream m (A.Array Word8)

727 -> D.Stream m Char

728decodeUtf8ArraysWithD cfm (D.Stream step state) =

729 D.Stream (step' utf8d) (OuterLoop state Nothing)

730 where

731 {-# INLINE transliterateOrError #-}

732 transliterateOrError e s =

733 case cfm of

734 ErrorOnCodingFailure -> error e

735 TransliterateCodingFailure -> YAndC replacementChar s

736 DropOnCodingFailure -> s

737 {-# INLINE inputUnderflow #-}

738 inputUnderflow =

739 case cfm of

740 ErrorOnCodingFailure ->

741 error $

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

743 ++ "decodeUtf8ArraysWith: Input Underflow"

744 TransliterateCodingFailure -> YAndC replacementChar D

745 DropOnCodingFailure -> D

746 {-# INLINE_LATE step' #-}

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

748 r <- step (adaptState gst) st

749 return $

750 case r of

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

752 Skip (InnerLoopDecodeInit s arrContents arrStart arrEnd)

753 Skip s -> Skip (OuterLoop s Nothing)

754 Stop -> Skip D

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

756 r <- step (adaptState gst) st

757 return $

758 case r of

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

760 Skip (InnerLoopDecoding s arrContents arrStart arrEnd ds cp)

761 Skip s -> Skip (OuterLoop s dst)

762 Stop -> Skip inputUnderflow

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

764 | p == end = do

765 return $ Skip $ OuterLoop st Nothing

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

767 x <- liftIO $ peekWith contents p

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

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

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

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

772 -- branch predication.

773 case x > 0x7f of

774 False ->

775 return $ Skip $ YAndC

776 (unsafeChr (fromIntegral x))

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

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

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

780 -- non-ascii case.

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

782

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

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

785 return $

786 case sv of

787 12 ->

788 Skip $

789 transliterateOrError

790 (

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

792 ++ "decodeUtf8ArraysWith: Invalid UTF8"

793 ++ " codepoint encountered"

794 )

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

796 0 -> error "unreachable state"

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

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

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

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

801 x <- liftIO $ peekWith contents p

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

803 return $

804 case sv of

805 0 ->

806 Skip $

807 YAndC

808 (unsafeChr cp)

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

810 12 ->

811 Skip $

812 transliterateOrError

813 (

814 "Streamly.Internal.Data.Stream.StreamD."

815 ++ "decodeUtf8ArraysWith: Invalid UTF8"

816 ++ " codepoint encountered"

817 )

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

819 _ ->

820 Skip

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

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

823 step' _ _ D = return Stop

824

825{-# INLINE decodeUtf8ArraysD #-}

826decodeUtf8ArraysD ::

827 MonadIO m

828 => D.Stream m (A.Array Word8)

829 -> D.Stream m Char

830decodeUtf8ArraysD = decodeUtf8ArraysWithD TransliterateCodingFailure

831

832-- |

833--

834-- /Pre-release/

835{-# INLINE decodeUtf8Arrays #-}

836decodeUtf8Arrays ::

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

838decodeUtf8Arrays =

839 fromStreamD . decodeUtf8ArraysD . toStreamD

840

841{-# INLINE decodeUtf8ArraysD' #-}

842decodeUtf8ArraysD' ::

843 MonadIO m

844 => D.Stream m (A.Array Word8)

845 -> D.Stream m Char

846decodeUtf8ArraysD' = decodeUtf8ArraysWithD ErrorOnCodingFailure

847

848-- |

849--

850-- /Pre-release/

851{-# INLINE decodeUtf8Arrays' #-}

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

853decodeUtf8Arrays' = fromStreamD . decodeUtf8ArraysD' . toStreamD

854

855{-# INLINE decodeUtf8ArraysD_ #-}

856decodeUtf8ArraysD_ ::

857 MonadIO m

858 => D.Stream m (A.Array Word8)

859 -> D.Stream m Char

860decodeUtf8ArraysD_ = decodeUtf8ArraysWithD DropOnCodingFailure

861

862-- |

863--

864-- /Pre-release/

865{-# INLINE decodeUtf8Arrays_ #-}

866decodeUtf8Arrays_ ::

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

868decodeUtf8Arrays_ =

869 fromStreamD . decodeUtf8ArraysD_ . toStreamD

870

871-------------------------------------------------------------------------------

872-- Encoding Unicode (UTF-8) Characters

873-------------------------------------------------------------------------------

874

875data WList = WCons !Word8 !WList | WNil

876

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

878

879{-# INLINE ord2 #-}

880ord2 :: Char -> WList

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

882 where

883 n = ord c

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

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

886

887{-# INLINE ord3 #-}

888ord3 :: Char -> WList

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

890 where

891 n = ord c

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

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

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

895

896{-# INLINE ord4 #-}

897ord4 :: Char -> WList

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

899 where

900 n = ord c

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

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

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

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

905

906{-# INLINE_NORMAL readCharUtf8With #-}

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

908readCharUtf8With surr = Unfold step inject

909

910 where

911

912 inject c =

913 return $ case ord c of

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

915 | x <= 0x7FF -> ord2 c

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

917 | otherwise -> ord4 c

918

919 {-# INLINE_LATE step #-}

920 step WNil = return Stop

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

922

923{-# INLINE_NORMAL readCharUtf8' #-}

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

925readCharUtf8' =

926 readCharUtf8With $

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

928

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

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

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

932-- paths (slow path).

933{-# INLINE_NORMAL encodeUtf8D' #-}

934encodeUtf8D' :: Monad m => D.Stream m Char -> D.Stream m Word8

935encodeUtf8D' = D.unfoldMany readCharUtf8'

936

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

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

939-- function errors out.

940--

941-- @since 0.8.0

942{-# INLINE encodeUtf8' #-}

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

944encodeUtf8' = fromStreamD . encodeUtf8D' . toStreamD

945

946{-# INLINE_NORMAL readCharUtf8 #-}

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

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

949

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

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

952--

953{-# INLINE_NORMAL encodeUtf8D #-}

954encodeUtf8D :: Monad m => D.Stream m Char -> D.Stream m Word8

955encodeUtf8D = D.unfoldMany readCharUtf8

956

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

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

959-- Unicode replacement character U+FFFD.

960--

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

962--

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

964{-# INLINE encodeUtf8 #-}

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

966encodeUtf8 = fromStreamD . encodeUtf8D . toStreamD

967

968{-# INLINE_NORMAL readCharUtf8_ #-}

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

970readCharUtf8_ = readCharUtf8With WNil

971

972{-# INLINE_NORMAL encodeUtf8D_ #-}

973encodeUtf8D_ :: Monad m => D.Stream m Char -> D.Stream m Word8

974encodeUtf8D_ = D.unfoldMany readCharUtf8_

975

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

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

978--

979-- @since 0.8.0

980{-# INLINE encodeUtf8_ #-}

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

982encodeUtf8_ = fromStreamD . encodeUtf8D_ . toStreamD

983

984-- | Same as 'encodeUtf8'

985--

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

987{-# INLINE encodeUtf8Lax #-}

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

989encodeUtf8Lax = encodeUtf8

990

991-------------------------------------------------------------------------------

992-- Decoding string literals

993-------------------------------------------------------------------------------

994

995-- | Read UTF-8 encoded bytes as chars from an 'Addr#' until a 0 byte is

996-- encountered, the 0 byte is not included in the stream.

997--

998-- /Unsafe:/ The caller is responsible for safe addressing.

999--

1000-- Note that this is completely safe when reading from Haskell string

1001-- literals because they are guaranteed to be NULL terminated:

1002--

1003-- >>> Stream.fold Fold.toList (Unicode.fromStr# "Haskell"#)

1004-- "Haskell"

1005--

1006{-# INLINE fromStr# #-}

1007fromStr# :: MonadIO m => Addr# -> Stream m Char

1008fromStr# addr = decodeUtf8 $ Stream.fromByteStr# addr

1009

1010-------------------------------------------------------------------------------

1011-- Encode streams of containers

1012-------------------------------------------------------------------------------

1013

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

1015-- Char stream and an encoding function.

1016--

1017-- /Internal/

1018{-# INLINE encodeObject #-}

1019encodeObject :: MonadIO m =>

1020 (Stream m Char -> Stream m Word8)

1021 -> Unfold m a Char

1022 -> a

1023 -> m (Array Word8)

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

1025

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

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

1028--

1029-- /Internal/

1030{-# INLINE encodeObjects #-}

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

1032 (Stream m Char -> Stream m Word8)

1033 -> Unfold m a Char

1034 -> t m a

1035 -> t m (Array Word8)

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

1037

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

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

1040--

1041-- @since 0.8.0

1042{-# INLINE encodeStrings #-}

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

1044 (Stream m Char -> Stream m Word8) -> t m String -> t m (Array Word8)

1045encodeStrings encode = encodeObjects encode Unfold.fromList

1046

1047{-

1048-------------------------------------------------------------------------------

1049-- Utility operations on strings

1050-------------------------------------------------------------------------------

1051

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

1053strip = undefined

1054

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

1056stripTail = undefined

1057-}

1058

1059-- | Remove leading whitespace from a string.

1060--

1061-- > stripHead = S.dropWhile isSpace

1062--

1063-- /Pre-release/

1064{-# INLINE stripHead #-}

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

1066stripHead = S.dropWhile isSpace

1067

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

1069-- and stream the result.

1070--

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

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

1073--

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

1075--

1076-- /Pre-release/

1077{-# INLINE lines #-}

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

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

1080

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

1082foreign import ccall unsafe "u_iswspace"

1083 iswspace :: Int -> Int

1084#endif

1085

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

1087{-# INLINE isSpace #-}

1088isSpace :: Char -> Bool

1089isSpace c

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

1091#if MIN_VERSION_base(4,17,0)

1092 | otherwise = generalCategory c == Space

1093#else

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

1095#endif

1096 where

1097 uc = fromIntegral (ord c) :: Word

1098

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

1100-- and stream the result.

1101--

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

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

1104--

1105-- > words = S.wordsBy isSpace

1106--

1107-- /Pre-release/

1108{-# INLINE words #-}

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

1110words = S.wordsBy isSpace

1111

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

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

1114--

1115-- @

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

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

1118-- @

1119--

1120-- /Pre-release/

1121{-# INLINE unlines #-}

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

1123unlines = S.interposeSuffix '\n'

1124

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

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

1127-- the streams.

1128--

1129-- @

1130-- unwords = Stream.interpose ' '

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

1132-- @

1133--

1134-- /Pre-release/

1135{-# INLINE unwords #-}

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

1137unwords = S.interpose ' '