2b72471 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Introduce many distinct "string" types to help ensure appropriate escaping on code gen

2b72471Evan Czaplicki7 years ago

compiler/src/Data/Name.hs+106−117

compare with master

unifiedsplit

@@ -1,17 +1,18 @@

1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}

3module Data.Name

4 ( Name

5− , toUtf8

5+ --

6− , fromUtf8

6+ , toChars

7− , toEscapedBuilder

7+ , toElmString

8− , Utf8.toBuilder

8+ , toBuilder

9+ --

9− , Utf8.fromPtr

10+ , fromPtr

10− , Utf8.fromChars

11+ , fromChars

11− , Utf8.toChars

12− -- misc

12+ --

13 , getKernel

14 , hasDot

15+ , splitDots

15 , isKernel

16 , isKernel

16 , isNumberType

17 , isNumberType

17 , isComparableType

18 , isComparableType

@@ -24,13 +25,13 @@ module Data.Name

24 , fromTypeVariable

25 , fromTypeVariable

25 , fromTypeVariableScheme

26 , fromTypeVariableScheme

26 , sepBy

27 , sepBy

27− -- interned

28+ --

28 , int, float, bool, char, string

29 , int, float, bool, char, string

29 , maybe, result, list, array, dict, tuple, jsArray

30 , maybe, result, list, array, dict, tuple, jsArray

30 , task, router, cmd, sub, platform, virtualDom

31 , task, router, cmd, sub, platform, virtualDom

31 , shader, debug, debugger, bitwise, basics

32 , shader, debug, debugger, bitwise, basics

32 , utils, negate, true, false, value

33 , utils, negate, true, false, value

33− , node, program, main, dollar, identity

34+ , node, program, _main, _Main, dollar, identity

34 , replModule

35 , replModule

35 )

36 )

36 where

37 where

@@ -38,9 +39,11 @@ module Data.Name

39import Prelude hiding (length, maybe, negate)

40import Prelude hiding (length, maybe, negate)

40import Control.Exception (assert)

41import Control.Exception (assert)

42+import qualified Data.Binary as Binary

41import qualified Data.ByteString.Builder.Internal as B

43import qualified Data.ByteString.Builder.Internal as B

42−import Data.Coerce (coerce)

44+import qualified Data.Coerce as Coerce

43import qualified Data.List as List

45import qualified Data.List as List

46+import qualified Data.String as Chars

44import qualified Data.Utf8 as Utf8

47import qualified Data.Utf8 as Utf8

45import Foreign.Ptr (plusPtr, minusPtr)

48import Foreign.Ptr (plusPtr, minusPtr)

46import GHC.Exts

49import GHC.Exts

@@ -59,72 +62,64 @@ import GHC.ST (ST(ST), runST)

59import GHC.Prim

62import GHC.Prim

60import GHC.Word (Word8(W8#))

63import GHC.Word (Word8(W8#))

65+import qualified Elm.String as ES

66+

64-- NAME

69-- NAME

67−type Name = Utf8.Under256 NAME

72+type Name =

73+ Utf8.Utf8 ELM_NAME

70−data NAME

76+data ELM_NAME

73−toUtf8 :: Name -> Utf8.String

74−toUtf8 =

75− coerce

80+-- INSTANCES

78−fromUtf8 :: Utf8.String -> Name

79−fromUtf8 =

80− coerce

83+instance Chars.IsString (Utf8.Utf8 ELM_NAME) where

84+ fromString = Utf8.fromChars

86+instance Binary.Binary (Utf8.Utf8 ELM_NAME) where

87+ get = Utf8.getUnder256

88+ put = Utf8.putUnder256

84−-- TO ESCAPED BUILDER

87−{-# INLINE toEscapedBuilder #-}

92+-- TO

88−toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder

89−toEscapedBuilder before after =

90− \name -> B.builder (toEscapedBuilderHelp before after name)

93−{-# INLINE toEscapedBuilderHelp #-}

95+toChars :: Name -> [Char]

94−toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a

96+toChars =

95−toEscapedBuilderHelp before after !name@(Utf8.Utf8 ba#) k =

97+ Utf8.toChars

96− go 0 (I# (sizeofByteArray# ba#))

97− where

98− go !offset !len !(B.BufferRange bOffset bEnd) =

99− let

100− !bLen = minusPtr bEnd bOffset

101− in

102− if len <= bLen then

103− do -- TODO test if writing word-by-word is faster

104− stToIO (copyToPtr name offset bOffset len)

105− stToIO (escape before after bOffset name offset len 0)

106− let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd

107− k newBufferRange

108− else

109− do stToIO (copyToPtr name offset bOffset bLen)

110− stToIO (escape before after bOffset name offset bLen 0)

111− let !newOffset = offset + bLen

112− let !newLength = len - bLen

113− return $ B.bufferFull 1 bEnd (go newOffset newLength)

114−

115−

116−escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> Int -> ST RealWorld ()

117−escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =

118− if isTrue# (i# <# len#) then

119− if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))

120− then

121− do writeWordToPtr ptr i after

122− escape before after ptr name offset len (i + 1)

123− else

124− do escape before after ptr name offset len (i + 1)

125

126− else

99+

127− return ()

100+toElmString :: Name -> ES.String

101+toElmString =

102+ Coerce.coerce

103+

104+

105+{-# INLINE toBuilder #-}

106+toBuilder :: Name -> B.Builder

107+toBuilder =

108+ Utf8.toBuilder

109+

110+

111+

112+-- FROM

113+

114+

115+fromPtr :: Ptr Word8 -> Ptr Word8 -> Name

116+fromPtr =

117+ Utf8.fromPtr

118+

119+

120+fromChars :: [Char] -> Name

121+fromChars =

122+ Utf8.fromChars

128

123

129

124

130

125

@@ -133,7 +128,12 @@ escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) l

133

128

134hasDot :: Name -> Bool

129hasDot :: Name -> Bool

135hasDot name =

130hasDot name =

136− Utf8.contains 0x2E {- . -} (coerce name)

131+ Utf8.contains 0x2E {- . -} name

132+

133+

134+splitDots :: Name -> [Name]

135+splitDots name =

136+ Utf8.split 0x2E {- . -} name

137

138

139

@@ -181,23 +181,23 @@ isCompappendType = Utf8.startsWith prefix_compappend

181

182{-# NOINLINE prefix_kernel #-}

183prefix_kernel :: Name

184−prefix_kernel = "Elm.Kernel."

184+prefix_kernel = fromChars "Elm.Kernel."

185

186{-# NOINLINE prefix_number #-}

187prefix_number :: Name

188−prefix_number = "number"

188+prefix_number = fromChars "number"

189

190{-# NOINLINE prefix_comparable #-}

191prefix_comparable :: Name

192−prefix_comparable = "comparable"

192+prefix_comparable = fromChars "comparable"

193

194{-# NOINLINE prefix_appendable #-}

195prefix_appendable :: Name

196−prefix_appendable = "appendable"

196+prefix_appendable = fromChars "appendable"

197

198{-# NOINLINE prefix_compappend #-}

199prefix_compappend :: Name

200−prefix_compappend = "compappend"

200+prefix_compappend = fromChars "compappend"

201

202

203

@@ -423,22 +423,6 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

423 s -> (# s, () #)

424

425

426−{-# INLINE writeWordToPtr #-}

427−writeWordToPtr :: Ptr a -> Int -> Word8 -> ST s ()

428−writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =

429− ST $ \s ->

430− case writeWord8OffAddr# addr# offset# word# s of

431− s -> (# s, () #)

432−

433−

434−{-# INLINE copyToPtr #-}

435−copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()

436−copyToPtr (Utf8.Utf8 ba#) (I# offset#) (Ptr addr#) (I# len#) =

437− ST $ \s ->

438− case copyByteArrayToAddr# ba# offset# addr# len# s of

439− s -> (# s, () #)

440−

441−

442{-# INLINE copyToMBA #-}

426{-# INLINE copyToMBA #-}

443copyToMBA :: Name -> MBA s -> ST s ()

427copyToMBA :: Name -> MBA s -> ST s ()

444copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

428copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

@@ -453,169 +437,174 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

453

437

454{-# NOINLINE int #-}

438{-# NOINLINE int #-}

455int :: Name

439int :: Name

456−int = "Int"

440+int = fromChars "Int"

457

441

458

442

459{-# NOINLINE float #-}

443{-# NOINLINE float #-}

460float :: Name

444float :: Name

461−float = "Float"

445+float = fromChars "Float"

462

446

463

447

464{-# NOINLINE bool #-}

448{-# NOINLINE bool #-}

465bool :: Name

449bool :: Name

466−bool = "Bool"

450+bool = fromChars "Bool"

467

451

468

452

469{-# NOINLINE char #-}

453{-# NOINLINE char #-}

470char :: Name

454char :: Name

471−char = "Char"

455+char = fromChars "Char"

472

456

473

457

474{-# NOINLINE string #-}

458{-# NOINLINE string #-}

475string :: Name

459string :: Name

476−string = "String"

460+string = fromChars "String"

477

461

478

462

479{-# NOINLINE maybe #-}

463{-# NOINLINE maybe #-}

480maybe :: Name

464maybe :: Name

481−maybe = "Maybe"

465+maybe = fromChars "Maybe"

482

466

483

467

484{-# NOINLINE result #-}

468{-# NOINLINE result #-}

485result :: Name

469result :: Name

486−result = "Result"

470+result = fromChars "Result"

487

471

488

472

489{-# NOINLINE list #-}

473{-# NOINLINE list #-}

490list :: Name

474list :: Name

491−list = "List"

475+list = fromChars "List"

492

476

493

477

494{-# NOINLINE array #-}

478{-# NOINLINE array #-}

495array :: Name

479array :: Name

496−array = "Array"

480+array = fromChars "Array"

497

481

498

482

499{-# NOINLINE dict #-}

483{-# NOINLINE dict #-}

500dict :: Name

484dict :: Name

501−dict = "Dict"

485+dict = fromChars "Dict"

502

486

503

487

504{-# NOINLINE tuple #-}

488{-# NOINLINE tuple #-}

505tuple :: Name

489tuple :: Name

506−tuple = "Tuple"

490+tuple = fromChars "Tuple"

507

491

508

492

509{-# NOINLINE jsArray #-}

493{-# NOINLINE jsArray #-}

510jsArray :: Name

494jsArray :: Name

511−jsArray = "JsArray"

495+jsArray = fromChars "JsArray"

512

496

513

497

514{-# NOINLINE task #-}

498{-# NOINLINE task #-}

515task :: Name

499task :: Name

516−task = "Task"

500+task = fromChars "Task"

517

501

518

502

519{-# NOINLINE router #-}

503{-# NOINLINE router #-}

520router :: Name

504router :: Name

521−router = "Router"

505+router = fromChars "Router"

522

506

523

507

524{-# NOINLINE cmd #-}

508{-# NOINLINE cmd #-}

525cmd :: Name

509cmd :: Name

526−cmd = "Cmd"

510+cmd = fromChars "Cmd"

527

511

528

512

529{-# NOINLINE sub #-}

513{-# NOINLINE sub #-}

530sub :: Name

514sub :: Name

531−sub = "Sub"

515+sub = fromChars "Sub"

532

516

533

517

534{-# NOINLINE platform #-}

518{-# NOINLINE platform #-}

535platform :: Name

519platform :: Name

536−platform = "Platform"

520+platform = fromChars "Platform"

537

521

538

522

539{-# NOINLINE virtualDom #-}

523{-# NOINLINE virtualDom #-}

540virtualDom :: Name

524virtualDom :: Name

541−virtualDom = "VirtualDom"

525+virtualDom = fromChars "VirtualDom"

542

526

543

527

544{-# NOINLINE shader #-}

528{-# NOINLINE shader #-}

545shader :: Name

529shader :: Name

546−shader = "Shader"

530+shader = fromChars "Shader"

547

531

548

532

549{-# NOINLINE debug #-}

533{-# NOINLINE debug #-}

550debug :: Name

534debug :: Name

551−debug = "Debug"

535+debug = fromChars "Debug"

552

536

553

537

554{-# NOINLINE debugger #-}

538{-# NOINLINE debugger #-}

555debugger :: Name

539debugger :: Name

556−debugger = "Debugger"

540+debugger = fromChars "Debugger"

557

541

558

542

559{-# NOINLINE bitwise #-}

543{-# NOINLINE bitwise #-}

560bitwise :: Name

544bitwise :: Name

561−bitwise = "Bitwise"

545+bitwise = fromChars "Bitwise"

562

546

563

547

564{-# NOINLINE basics #-}

548{-# NOINLINE basics #-}

565basics :: Name

549basics :: Name

566−basics = "Basics"

550+basics = fromChars "Basics"

567

551

568

552

569{-# NOINLINE utils #-}

553{-# NOINLINE utils #-}

570utils :: Name

554utils :: Name

571−utils = "Utils"

555+utils = fromChars "Utils"

572

556

573

557

574{-# NOINLINE negate #-}

558{-# NOINLINE negate #-}

575negate :: Name

559negate :: Name

576−negate = "negate"

560+negate = fromChars "negate"

577

561

578

562

579{-# NOINLINE true #-}

563{-# NOINLINE true #-}

580true :: Name

564true :: Name

581−true = "True"

565+true = fromChars "True"

582

566

583

567

584{-# NOINLINE false #-}

568{-# NOINLINE false #-}

585false :: Name

569false :: Name

586−false = "False"

570+false = fromChars "False"

587

571

588

572

589{-# NOINLINE value #-}

573{-# NOINLINE value #-}

590value :: Name

574value :: Name

591−value = "Value"

575+value = fromChars "Value"

592

576

593

577

594{-# NOINLINE node #-}

578{-# NOINLINE node #-}

595node :: Name

579node :: Name

596−node = "Node"

580+node = fromChars "Node"

597

581

598

582

599{-# NOINLINE program #-}

583{-# NOINLINE program #-}

600program :: Name

584program :: Name

601−program = "Program"

585+program = fromChars "Program"

586+

587+

588+{-# NOINLINE _main #-}

589+_main :: Name

590+_main = fromChars "main"

602

591

603

592

604−{-# NOINLINE main #-}

593+{-# NOINLINE _Main #-}

605−main :: Name

594+_Main :: Name

606−main = "main"

595+_Main = fromChars "Main"

607

596

608

597

609{-# NOINLINE dollar #-}

598{-# NOINLINE dollar #-}

610dollar :: Name

599dollar :: Name

611−dollar = "$"

600+dollar = fromChars "$"

612

601

613

602

614{-# NOINLINE identity #-}

603{-# NOINLINE identity #-}

615identity :: Name

604identity :: Name

616−identity = "identity"

605+identity = fromChars "identity"

617

606

618

607

619{-# NOINLINE replModule #-}

608{-# NOINLINE replModule #-}

620replModule :: Name

609replModule :: Name

621−replModule = "Elm_Repl"

610+replModule = fromChars "Elm_Repl"

compiler/src/Data/Utf8.hs+149−294

@@ -1,37 +1,42 @@

1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}

2+{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}

3module Data.Utf8

4− ( String

5− , Utf8(..)

4+ ( Utf8(..)

6− , VeryLong

7− , Under256

8 , isEmpty

5 , isEmpty

9 , empty

6 , empty

10 , size

7 , size

11 , contains

8 , contains

12− , containsDouble

13 , startsWith

9 , startsWith

14 , startsWithChar

10 , startsWithChar

15− , endsWithWord

11+ , endsWithWord8

16 , split

12 , split

17 , join

13 , join

18− , all

14+ --

19− , any

15+ , getUnder256

20− , toWord16

16+ , putUnder256

21− , fromWord16

17+ --

22− -- conversions

18+ , getVeryLong

23− , fromChars

19+ , putVeryLong

20+ --

24 , toChars

21 , toChars

25 , toBuilder

22 , toBuilder

23+ , toEscapedBuilder

24+ --

26 , fromPtr

25 , fromPtr

27− , fromChunks

26+ , fromSnippet

28− , Chunk(..)

27+ , fromChars

28+ --

29+ , MBA

30+ , newByteArray

31+ , copyFromPtr

32+ , writeWord8

33+ , freeze

29 )

34 )

30 where

35 where

33import Prelude hiding (String, all, any, concat)

38import Prelude hiding (String, all, any, concat)

34−import Data.Binary (Binary(..), Get, getWord8, putWord8)

39+import Data.Binary (Get, get, getWord8, Put, put, putWord8)

35import Data.Binary.Put (putBuilder)

40import Data.Binary.Put (putBuilder)

36import Data.Binary.Get.Internal (readN)

41import Data.Binary.Get.Internal (readN)

37import Data.Bits ((.&.), shiftR)

42import Data.Bits ((.&.), shiftR)

@@ -39,7 +44,6 @@ import qualified Data.ByteString.Internal as B

39import qualified Data.ByteString.Builder.Internal as B

44import qualified Data.ByteString.Builder.Internal as B

40import qualified Data.Char as Char

45import qualified Data.Char as Char

41import qualified Data.List as List

46import qualified Data.List as List

42−import Data.String (IsString(..))

43import Foreign.ForeignPtr (touchForeignPtr)

47import Foreign.ForeignPtr (touchForeignPtr)

44import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

48import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

45import Foreign.Ptr (minusPtr, plusPtr)

49import Foreign.Ptr (minusPtr, plusPtr)

@@ -54,36 +58,35 @@ import GHC.Exts

54 , copyByteArray#

58 , copyByteArray#

55 , copyAddrToByteArray#

59 , copyAddrToByteArray#

56 , copyByteArrayToAddr#

60 , copyByteArrayToAddr#

57− , writeWord8Array#,

61+ , writeWord8Array#

58 )

62 )

59import GHC.IO

63import GHC.IO

60import GHC.ST (ST(ST), runST)

64import GHC.ST (ST(ST), runST)

61import GHC.Prim

65import GHC.Prim

62import GHC.Word (Word8(W8#), Word16(W16#))

66import GHC.Word (Word8(W8#), Word16(W16#))

68+import qualified Parse.Primitives as P

69+

66-- UTF-8

72-- UTF-8

69−data Utf8 size tipe =

75+data Utf8 tipe =

70 Utf8 ByteArray#

76 Utf8 ByteArray#

73−type String = Utf8 VERY_LONG STRING

74−type VeryLong t = Utf8 VERY_LONG t

75−type Under256 t = Utf8 UNDER_256 t

76−

77−data STRING

78−data VERY_LONG

79−data UNDER_256

80+-- EMPTY

83−-- IS EMPTY

83+{-# NOINLINE empty #-}

84+empty :: Utf8 t

85+empty =

86+ runST (freeze =<< newByteArray 0)

86−isEmpty :: Utf8 l t -> Bool

89+isEmpty :: Utf8 t -> Bool

87isEmpty (Utf8 ba#) =

90isEmpty (Utf8 ba#) =

88 isTrue# (sizeofByteArray# ba# ==# 0#)

91 isTrue# (sizeofByteArray# ba# ==# 0#)

@@ -92,7 +95,7 @@ isEmpty (Utf8 ba#) =

92-- SIZE

95-- SIZE

95−size :: Utf8 l t -> Int

98+size :: Utf8 t -> Int

96size (Utf8 ba#) =

99size (Utf8 ba#) =

97 I# (sizeofByteArray# ba#)

100 I# (sizeofByteArray# ba#)

101

@@ -101,7 +104,7 @@ size (Utf8 ba#) =

101-- CONTAINS

104-- CONTAINS

102

105

103

106

104−contains :: Word8 -> Utf8 l t -> Bool

107+contains :: Word8 -> Utf8 t -> Bool

105contains (W8# word#) (Utf8 ba#) =

108contains (W8# word#) (Utf8 ba#) =

106 containsHelp word# ba# 0# (sizeofByteArray# ba#)

109 containsHelp word# ba# 0# (sizeofByteArray# ba#)

107

110

@@ -117,32 +120,11 @@ containsHelp word# ba# !offset# len# =

117

120

118

121

119

122

120−-- CONTAINS DOUBLE

121−

122−

123−containsDouble :: Word8 -> Utf8 l t -> Bool

124−containsDouble (W8# word#) (Utf8 ba#) =

125− containsDoubleHelp word# ba# 0# (sizeofByteArray# ba#)

126−

127−

128−containsDoubleHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool

129−containsDoubleHelp word# ba# !offset# len# =

130− let !offset1# = offset# +# 1# in

131− if isTrue# (offset1# <# len#) then

132− if isTrue# (eqWord# word# (indexWord8Array# ba# offset# ))

133− && isTrue# (eqWord# word# (indexWord8Array# ba# offset1#))

134− then True

135− else containsDoubleHelp word# ba# (offset# +# 1#) len#

136− else

137− False

138−

139−

140−

141-- STARTS WITH

123-- STARTS WITH

142

124

143

125

144{-# INLINE startsWith #-}

126{-# INLINE startsWith #-}

145−startsWith :: Utf8 l t -> Utf8 l t -> Bool

127+startsWith :: Utf8 t -> Utf8 t -> Bool

146startsWith (Utf8 ba1#) (Utf8 ba2#) =

128startsWith (Utf8 ba1#) (Utf8 ba2#) =

147 let

129 let

148 !len1# = sizeofByteArray# ba1#

130 !len1# = sizeofByteArray# ba1#

@@ -157,9 +139,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =

157-- STARTS WITH CHAR

139-- STARTS WITH CHAR

158

140

159

141

160−startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool

142+startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool

161−startsWithChar isGood str@(Utf8 ba#) =

143+startsWithChar isGood bytes@(Utf8 ba#) =

162− if isEmpty str then

144+ if isEmpty bytes then

163 False

145 False

164 else

146 else

165 let

147 let

@@ -177,8 +159,8 @@ startsWithChar isGood str@(Utf8 ba#) =

177-- ENDS WITH WORD

159-- ENDS WITH WORD

178

160

179

161

180−endsWithWord :: Word8 -> Utf8 l t -> Bool

162+endsWithWord8 :: Word8 -> Utf8 t -> Bool

181−endsWithWord (W8# w#) (Utf8 ba#) =

163+endsWithWord8 (W8# w#) (Utf8 ba#) =

182 let len# = sizeofByteArray# ba# in

164 let len# = sizeofByteArray# ba# in

183 isTrue# (len# ># 0#)

165 isTrue# (len# ># 0#)

184 &&

166 &&

@@ -189,12 +171,12 @@ endsWithWord (W8# w#) (Utf8 ba#) =

189-- SPLIT

171-- SPLIT

190

172

191

173

192−split :: Word8 -> String -> [String]

174+split :: Word8 -> Utf8 t -> [Utf8 t]

193split (W8# divider#) str@(Utf8 ba#) =

175split (W8# divider#) str@(Utf8 ba#) =

194 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])

176 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])

195

177

196

178

197−splitHelp :: String -> Int -> [Int] -> [String]

179+splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]

198splitHelp str start offsets =

180splitHelp str start offsets =

199 case offsets of

181 case offsets of

200 [] ->

182 [] ->

@@ -215,7 +197,7 @@ findDividers divider# ba# !offset# len# revOffsets =

215 reverse revOffsets

197 reverse revOffsets

216

198

217

199

218−unsafeSlice :: String -> Int -> Int -> String

200+unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t

219unsafeSlice str start end =

201unsafeSlice str start end =

220 let !len = end - start in

202 let !len = end - start in

221 if len == 0 then

203 if len == 0 then

@@ -231,7 +213,7 @@ unsafeSlice str start end =

231-- JOIN

213-- JOIN

232

214

233

215

234−join :: Word8 -> [String] -> String

216+join :: Word8 -> [Utf8 t] -> Utf8 t

235join sep strings =

217join sep strings =

236 case strings of

218 case strings of

237 [] ->

219 [] ->

@@ -245,7 +227,7 @@ join sep strings =

245 freeze mba

227 freeze mba

246

228

247

229

248−joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()

230+joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()

249joinHelp sep mba offset str strings =

231joinHelp sep mba offset str strings =

250 let

232 let

251 !len = size str

233 !len = size str

@@ -263,46 +245,10 @@ joinHelp sep mba offset str strings =

263

245

264

246

265

247

266−-- ALL

267−

268−

269−all :: (Char -> Bool) -> Utf8 l t -> Bool

270−all isGood utf8 =

271− not (any (not . isGood) utf8)

272−

273−

274−

275−-- ANY

276−

277−

278−any :: (Char -> Bool) -> Utf8 l t -> Bool

279−any isGood (Utf8 ba#) =

280− anyHelp isGood ba# 0# (sizeofByteArray# ba#)

281−

282−

283−anyHelp :: (Char -> Bool) -> ByteArray# -> Int# -> Int# -> Bool

284−anyHelp isGood ba# offset# len# =

285− if isTrue# (offset# >=# len#) then

286− False

287− else

288− let

289− !w# = indexWord8Array# ba# offset#

290− !(# char, width# #)

291− | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)

292− | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)

293− | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)

294− | True = (# chr4 ba# offset# w#, 4# #)

295− in

296− if isGood char

297− then True

298− else anyHelp isGood ba# (offset# +# width#) len#

299−

300−

301−

302-- EQUAL

248-- EQUAL

303

249

304

250

305−instance Eq (Utf8 l t) where

251+instance Eq (Utf8 t) where

306 (==) (Utf8 ba1#) (Utf8 ba2#) =

252 (==) (Utf8 ba1#) (Utf8 ba2#) =

307 let

253 let

308 !len1# = sizeofByteArray# ba1#

254 !len1# = sizeofByteArray# ba1#

@@ -317,7 +263,7 @@ instance Eq (Utf8 l t) where

317-- COMPARE

263-- COMPARE

318

264

319

265

320−instance Ord (Utf8 l t) where

266+instance Ord (Utf8 t) where

321 compare (Utf8 ba1#) (Utf8 ba2#) =

267 compare (Utf8 ba1#) (Utf8 ba2#) =

322 let

268 let

323 !len1# = sizeofByteArray# ba1#

269 !len1# = sizeofByteArray# ba1#

@@ -334,84 +280,20 @@ instance Ord (Utf8 l t) where

334

280

335

281

336

282

337−-- TO WORD16

338−

339−

340−toWord16 :: String -> Maybe Word16

341−toWord16 (Utf8 ba#) =

342− let !len# = sizeofByteArray# ba# in

343− if isTrue# (len# ==# 0#) then

344− Nothing

345− else

346− let !w# = indexWord8Array# ba# 0# in

347− if isTrue# (eqWord# w# 0x30##) then

348− if isTrue# (len# ==# 1#) then Just 0 else Nothing

349− else

350− toWordHelp ba# 0# len# 0##

351−

352−

353−toWordHelp :: ByteArray# -> Int# -> Int# -> Word# -> Maybe Word16

354−toWordHelp ba# offset# len# number# =

355− if isTrue# (offset# <# len#) then

356− let !w# = indexWord8Array# ba# offset# in

357− if isTrue# (leWord# w# 0x39##) && isTrue# (geWord# w# 0x30##) then

358− let !newNumber# = plusWord# (timesWord# 10## number#) (minusWord# w# 0x30##) in

359− toWordHelp ba# (offset# +# 1#) len# newNumber#

360− else

361− Nothing

362− else

363− Just (W16# number#)

364−

365−

366−

367−-- FROM WORD16

368−

369−

370−fromWord16 :: Word16 -> String

371−fromWord16 n =

372− runST $

373− do let !size = getWordSize n

374− mba <- newByteArray size

375− writeDigits mba (size - 1) n

376− freeze mba

377−

378−

379−getWordSize :: Word16 -> Int

380−getWordSize n

381− | n < 10 = 1

382− | n < 100 = 2

383− | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)

384−

385−

386−writeDigits :: MBA s -> Int -> Word16 -> ST s ()

387−writeDigits !mba !offset !n =

388− do let (q,r) = quotRem n 10

389− writeWord8 mba offset (0x30 + fromIntegral r)

390− if q <= 0

391− then return ()

392− else writeDigits mba (offset-1) q

393−

394−

395−

396-- FROM STRING

283-- FROM STRING

397

284

398

285

399−fromChars :: [Char] -> Utf8 l t

286+fromChars :: [Char] -> Utf8 t

400−fromChars =

287+fromChars chars =

401− fromString

402−

403−

404−instance IsString (Utf8 l t) where

405− fromString str =

406− runST

288+ runST

407− (

289+ (

408− do mba <- newByteArray (sum (map getWidth str))

290+ do mba <- newByteArray (sum (map getWidth chars))

409− writeString mba 0 str

291+ writeChars mba 0 chars

410− )

292+ )

411

293

412

294

413−writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)

295+writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)

414−writeString !mba !offset chars =

296+writeChars !mba !offset chars =

415 case chars of

297 case chars of

416 [] ->

298 [] ->

417 freeze mba

299 freeze mba

@@ -419,25 +301,25 @@ writeString !mba !offset chars =

419 char : chars

301 char : chars

420 | n < 0x80 ->

302 | n < 0x80 ->

421 do writeWord8 mba (offset ) (fromIntegral n)

303 do writeWord8 mba (offset ) (fromIntegral n)

422− writeString mba (offset + 1) chars

304+ writeChars mba (offset + 1) chars

423

305

424 | n < 0x800 ->

306 | n < 0x800 ->

425 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))

307 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))

426 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))

308 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))

427− writeString mba (offset + 2) chars

309+ writeChars mba (offset + 2) chars

428

310

429 | n < 0x10000 ->

311 | n < 0x10000 ->

430 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))

312 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))

431 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

313 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

432 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))

314 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))

433− writeString mba (offset + 3) chars

315+ writeChars mba (offset + 3) chars

434

316

435 | otherwise ->

317 | otherwise ->

436 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))

318 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))

437 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))

319 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))

438 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

320 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

439 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))

321 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))

440− writeString mba (offset + 4) chars

322+ writeChars mba (offset + 4) chars

441

323

442 where

324 where

443 n = Char.ord char

325 n = Char.ord char

@@ -455,10 +337,10 @@ getWidth char

455

337

456

338

457

339

458−-- TO STRING

340+-- TO CHARS

459

341

460

342

461−toChars :: Utf8 l t -> [Char]

343+toChars :: Utf8 t -> [Char]

462toChars (Utf8 ba#) =

344toChars (Utf8 ba#) =

463 toCharsHelp ba# 0# (sizeofByteArray# ba#)

345 toCharsHelp ba# 0# (sizeofByteArray# ba#)

464

346

@@ -528,13 +410,13 @@ chr4 ba# offset# firstWord# =

528

410

529

411

530{-# INLINE toBuilder #-}

412{-# INLINE toBuilder #-}

531−toBuilder :: Utf8 l t -> B.Builder

413+toBuilder :: Utf8 t -> B.Builder

532toBuilder =

414toBuilder =

533 \bytes -> B.builder (toBuilderHelp bytes)

415 \bytes -> B.builder (toBuilderHelp bytes)

534

416

535

417

536{-# INLINE toBuilderHelp #-}

418{-# INLINE toBuilderHelp #-}

537−toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a

419+toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a

538toBuilderHelp !bytes@(Utf8 ba#) k =

420toBuilderHelp !bytes@(Utf8 ba#) k =

539 go 0 (I# (sizeofByteArray# ba#))

421 go 0 (I# (sizeofByteArray# ba#))

540 where

422 where

@@ -554,144 +436,109 @@ toBuilderHelp !bytes@(Utf8 ba#) k =

554

436

555

437

556

438

557−-- FROM PTR

439+-- TO ESCAPED BUILDER

558

440

559

441

442+{-# INLINE toEscapedBuilder #-}

560−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t

443+toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder

561−fromPtr pos end =

444+toEscapedBuilder before after =

562− unsafeDupablePerformIO (stToIO (

445+ \name -> B.builder (toEscapedBuilderHelp before after name)

563− do let !len = minusPtr end pos

564− mba <- newByteArray len

565− copyFromPtr pos mba 0 len

566− freeze mba

567− ))

568

446

569

447

448+{-# INLINE toEscapedBuilderHelp #-}

449+toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a

450+toEscapedBuilderHelp before after !name@(Utf8 ba#) k =

451+ go 0 (I# (sizeofByteArray# ba#))

452+ where

453+ go !offset !len !(B.BufferRange bOffset bEnd) =

454+ let

455+ !bLen = minusPtr bEnd bOffset

456+ in

457+ if len <= bLen then

458+ do -- TODO test if writing word-by-word is faster

459+ copyToPtr name offset bOffset len

460+ escape before after bOffset name offset len 0

461+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd

462+ k newBufferRange

463+ else

464+ do copyToPtr name offset bOffset bLen

465+ escape before after bOffset name offset bLen 0

466+ let !newOffset = offset + bLen

467+ let !newLength = len - bLen

468+ return $ B.bufferFull 1 bEnd (go newOffset newLength)

469+

470+

471+escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO ()

472+escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =

473+ if isTrue# (i# <# len#) then

474+ if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))

475+ then

476+ do writeWordToPtr ptr i after

477+ escape before after ptr name offset len (i + 1)

478+ else

479+ do escape before after ptr name offset len (i + 1)

480+

481+ else

482+ return ()

570

483

571−-- FROM CHUNKS

572

484

573

485

574−data Chunk

486+-- FROM PTR

575− = Slice (Ptr Word8) Int

576− | Escape Word8

577− | CodePoint Int

578

487

579

488

580−fromChunks :: [Chunk] -> Utf8 l t

489+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t

581−fromChunks chunks =

490+fromPtr pos end =

582 unsafeDupablePerformIO (stToIO (

491 unsafeDupablePerformIO (stToIO (

583− do let !len = sum (map chunkToWidth chunks)

492+ do let !len = minusPtr end pos

584 mba <- newByteArray len

493 mba <- newByteArray len

585− writeChunks mba 0 chunks

494+ copyFromPtr pos mba 0 len

586 freeze mba

495 freeze mba

587 ))

496 ))

588

497

589

498

590−chunkToWidth :: Chunk -> Int

591−chunkToWidth chunk =

592− case chunk of

593− Slice _ len ->

594− len

595−

596− Escape _ ->

597− 2

598−

599− CodePoint code ->

600− if code < 0xFFFF then 6 else 12

601−

602−

603−writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()

604−writeChunks mba offset chunks =

605− case chunks of

606− [] ->

607− return ()

608−

609− chunk : chunks ->

610− case chunk of

611− Slice ptr len ->

612− do copyFromPtr ptr mba offset len

613− let !newOffset = offset + len

614− writeChunks mba newOffset chunks

615−

616− Escape word ->

617− do writeWord8 mba offset 0x5C {- \ -}

618− writeWord8 mba (offset + 1) word

619− let !newOffset = offset + 2

620− writeChunks mba newOffset chunks

621−

622− CodePoint code ->

623− if code < 0xFFFF then

624− do writeCode mba offset code

625− let !newOffset = offset + 6

626− writeChunks mba newOffset chunks

627− else

628− do let (hi,lo) = divMod (code - 0x10000) 0x400

629− writeCode mba (offset ) (hi + 0xD800)

630− writeCode mba (offset + 6) (lo + 0xDC00)

631− let !newOffset = offset + 12

632− writeChunks mba newOffset chunks

633−

634−

635−-- TODO see if it is faster to writeWord32 a block of hex-as-ascii

636−writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

637−writeCode mba offset code =

638− do writeWord8 mba offset 0x5C {- \ -}

639− writeWord8 mba (offset + 1) 0x75 {- u -}

640− writeHex mba (offset + 2) (shiftR code 12)

641− writeHex mba (offset + 3) (shiftR code 8)

642− writeHex mba (offset + 4) (shiftR code 4)

643− writeHex mba (offset + 5) code

644−

645−

646−writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

647−writeHex mba !offset !bits =

648− do let !n = fromIntegral bits .&. 0x0F

649− writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)

650

499

500+-- FROM SNIPPET

651

501

652

502

653−-- UNDER 256 BINARY

503+fromSnippet :: P.Snippet -> Utf8 t

654−

504+fromSnippet (P.Snippet fptr off len _ _) =

655−

505+ unsafeDupablePerformIO (stToIO (

656−instance Binary (Utf8 UNDER_256 t) where

506+ do mba <- newByteArray len

657− put bytes@(Utf8 ba#) =

507+ let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off

658− do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))

508+ copyFromPtr pos mba 0 len

659− putBuilder (toBuilder bytes)

509+ freeze mba

660− get =

510+ ))

661− getUnder256 =<< getWord8

662

511

663

512

664−{-# INLINE getUnder256 #-}

665−getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)

666−getUnder256 w =

667− let !n = fromIntegral w in

668− readN n (copyFromByteString n)

669

513

514+-- BINARY

670

515

671

516

672−-- VERY LONG BINARY

517+putUnder256 :: Utf8 t -> Put

518+putUnder256 bytes =

519+ do putWord8 (fromIntegral (size bytes))

520+ putBuilder (toBuilder bytes)

673

521

674

522

675−instance Binary (Utf8 VERY_LONG t) where

523+getUnder256 :: Get (Utf8 t)

676− put str =

524+getUnder256 =

677− do put (size str)

525+ do word <- getWord8

678− putBuilder (toBuilder str)

526+ let !n = fromIntegral word

679− get =

527+ readN n (copyFromByteString n)

680− getVeryLong =<< get

681

528

682

529

683−{-# INLINE getVeryLong #-}

530+putVeryLong :: Utf8 t -> Put

684−getVeryLong :: Int -> Get (Utf8 VERY_LONG t)

531+putVeryLong bytes =

685−getVeryLong n =

532+ do put (size bytes)

686− if n > 0

533+ putBuilder (toBuilder bytes)

687− then readN n (copyFromByteString n)

688− else return empty

689

534

690

535

691−{-# NOINLINE empty #-}

536+getVeryLong :: Get (Utf8 t)

692−empty :: Utf8 l t

537+getVeryLong =

693−empty =

538+ do n <- get

694− runST (freeze =<< newByteArray 0)

539+ if n > 0

540+ then readN n (copyFromByteString n)

541+ else return empty

695

542

696

543

697

544

@@ -699,7 +546,7 @@ empty =

699

546

700

547

701{-# INLINE copyFromByteString #-}

548{-# INLINE copyFromByteString #-}

702−copyFromByteString :: Int -> B.ByteString -> Utf8 l t

549+copyFromByteString :: Int -> B.ByteString -> Utf8 t

703copyFromByteString len (B.PS fptr offset _) =

550copyFromByteString len (B.PS fptr offset _) =

704 unsafeDupablePerformIO

551 unsafeDupablePerformIO

705 (

552 (

@@ -725,14 +572,14 @@ newByteArray (I# len#) =

725 (# s, mba# #) -> (# s, MBA# mba# #)

572 (# s, mba# #) -> (# s, MBA# mba# #)

726

573

727

574

728−freeze :: MBA s -> ST s (Utf8 l t)

575+freeze :: MBA s -> ST s (Utf8 t)

729freeze (MBA# mba#) =

576freeze (MBA# mba#) =

730 ST $ \s ->

577 ST $ \s ->

731 case unsafeFreezeByteArray# mba# s of

578 case unsafeFreezeByteArray# mba# s of

732 (# s, ba# #) -> (# s, Utf8 ba# #)

579 (# s, ba# #) -> (# s, Utf8 ba# #)

733

580

734

581

735−copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()

582+copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()

736copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =

583copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =

737 ST $ \s ->

584 ST $ \s ->

738 case copyByteArray# ba# offset# mba# i# len# s of

585 case copyByteArray# ba# offset# mba# i# len# s of

@@ -746,7 +593,7 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =

746 s -> (# s, () #)

593 s -> (# s, () #)

747

594

748

595

749−copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()

596+copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()

750copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =

597copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =

751 IO $ \s ->

598 IO $ \s ->

752 case copyByteArrayToAddr# ba# offset# mba# len# s of

599 case copyByteArrayToAddr# ba# offset# mba# len# s of

@@ -759,3 +606,11 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

759 ST $ \s ->

606 ST $ \s ->

760 case writeWord8Array# mba# offset# w# s of

607 case writeWord8Array# mba# offset# w# s of

761 s -> (# s, () #)

608 s -> (# s, () #)

609+

610+

611+{-# INLINE writeWordToPtr #-}

612+writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()

613+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =

614+ IO $ \s ->

615+ case writeWord8OffAddr# addr# offset# word# s of

616+ s -> (# s, () #)

compiler/src/Elm/Float.hsnew file+51

@@ -0,0 +1,51 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}

3+module Elm.Float

4+ ( Float

5+ , fromPtr

6+ , toBuilder

7+ )

8+ where

10+

11+import Prelude hiding (Float)

12+import Data.Binary (Binary, get, put)

13+import qualified Data.ByteString.Builder as B

14+import qualified Data.Utf8 as Utf8

15+import Data.Word (Word8)

16+import Foreign.Ptr (Ptr)

17+

18+

19+

20+-- FLOATS

21+

22+

23+type Float =

24+ Utf8.Utf8 ELM_FLOAT

25+

26+

27+data ELM_FLOAT

28+

29+

30+

31+-- HELPERS

32+

33+

34+fromPtr :: Ptr Word8 -> Ptr Word8 -> Float

35+fromPtr =

36+ Utf8.fromPtr

37+

38+

39+{-# INLINE toBuilder #-}

40+toBuilder :: Float -> B.Builder

41+toBuilder =

42+ Utf8.toBuilder

43+

44+

45+

46+-- BINARY

47+

48+

49+instance Binary (Utf8.Utf8 ELM_FLOAT) where

50+ get = Utf8.getUnder256

51+ put = Utf8.putUnder256

compiler/src/Elm/String.hsnew file+134

@@ -0,0 +1,134 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}

3+module Elm.String

4+ ( String

5+ , toChars

6+ , toBuilder

7+ , Chunk(..)

8+ , fromChunks

9+ )

10+ where

11+

12+

13+import Prelude hiding (String)

14+import Data.Binary (Binary, get, put)

15+import Data.Bits ((.&.), shiftR)

16+import qualified Data.ByteString.Builder as B

17+import qualified Data.Utf8 as Utf8

18+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)

19+import GHC.Exts (RealWorld, Ptr)

20+import GHC.IO (stToIO, unsafeDupablePerformIO)

21+import GHC.ST (ST)

22+import GHC.Word (Word8)

23+

24+

25+

26+-- STRINGS

27+

28+

29+type String =

30+ Utf8.Utf8 ELM_STRING

31+

32+

33+data ELM_STRING

34+

35+

36+

37+-- HELPERS

38+

39+

40+toChars :: String -> [Char]

41+toChars =

42+ Utf8.toChars

43+

44+

45+{-# INLINE toBuilder #-}

46+toBuilder :: String -> B.Builder

47+toBuilder =

48+ Utf8.toBuilder

49+

50+

51+

52+-- FROM CHUNKS

53+

54+

55+data Chunk

56+ = Slice (Ptr Word8) Int

57+ | Escape Word8

58+ | CodePoint Int

59+

60+

61+fromChunks :: [Chunk] -> String

62+fromChunks chunks =

63+ unsafeDupablePerformIO (stToIO (

64+ do let !len = sum (map chunkToWidth chunks)

65+ mba <- newByteArray len

66+ writeChunks mba 0 chunks

67+ freeze mba

68+ ))

69+

70+

71+chunkToWidth :: Chunk -> Int

72+chunkToWidth chunk =

73+ case chunk of

74+ Slice _ len -> len

75+ Escape _ -> 2

76+ CodePoint c -> if c < 0xFFFF then 6 else 12

77+

78+

79+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()

80+writeChunks mba offset chunks =

81+ case chunks of

82+ [] ->

83+ return ()

84+

85+ chunk : chunks ->

86+ case chunk of

87+ Slice ptr len ->

88+ do copyFromPtr ptr mba offset len

89+ let !newOffset = offset + len

90+ writeChunks mba newOffset chunks

91+

92+ Escape word ->

93+ do writeWord8 mba offset 0x5C {- \ -}

94+ writeWord8 mba (offset + 1) word

95+ let !newOffset = offset + 2

96+ writeChunks mba newOffset chunks

97+

98+ CodePoint code ->

99+ if code < 0xFFFF then

100+ do writeCode mba offset code

101+ let !newOffset = offset + 6

102+ writeChunks mba newOffset chunks

103+ else

104+ do let (hi,lo) = divMod (code - 0x10000) 0x400

105+ writeCode mba (offset ) (hi + 0xD800)

106+ writeCode mba (offset + 6) (lo + 0xDC00)

107+ let !newOffset = offset + 12

108+ writeChunks mba newOffset chunks

109+

110+

111+-- TODO see if it is faster to writeWord32 a block of hex-as-ascii

112+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

113+writeCode mba offset code =

114+ do writeWord8 mba offset 0x5C {- \ -}

115+ writeWord8 mba (offset + 1) 0x75 {- u -}

116+ writeHex mba (offset + 2) (shiftR code 12)

117+ writeHex mba (offset + 3) (shiftR code 8)

118+ writeHex mba (offset + 4) (shiftR code 4)

119+ writeHex mba (offset + 5) code

120+

121+

122+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

123+writeHex mba !offset !bits =

124+ do let !n = fromIntegral bits .&. 0x0F

125+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)

126+

127+

128+

129+-- BINARY

130+

131+

132+instance Binary (Utf8.Utf8 ELM_STRING) where

133+ get = Utf8.getVeryLong

134+ put = Utf8.putVeryLong

compiler/src/Json/String.hsnew file+184

@@ -0,0 +1,184 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls #-}

3+module Json.String

4+ ( String

5+ --

6+ , fromPtr

7+ , fromName

8+ , fromChars

9+ , fromSnippet

10+ , fromComment

11+ --

12+ , toChars

13+ , toBuilder

14+ )

15+ where

16+

17+

18+import Prelude hiding (String)

19+import qualified Data.ByteString.Builder as B

20+import qualified Data.Coerce as Coerce

21+import qualified Data.Name as Name

22+import qualified Data.Utf8 as Utf8

23+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)

24+import Data.Word (Word8)

25+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

26+import Foreign.ForeignPtr (withForeignPtr)

27+import GHC.Exts (RealWorld)

28+import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)

29+import GHC.ST (ST)

30+

31+import qualified Parse.Primitives as P

32+

33+

34+

35+-- JSON STRINGS

36+

37+

38+type String =

39+ Utf8.Utf8 JSON_STRING -- TODO is this the right representation? Maybe ByteString instead?

40+

41+

42+data JSON_STRING

43+

44+

45+

46+-- FROM

47+

48+

49+fromPtr :: Ptr Word8 -> Ptr Word8 -> String

50+fromPtr =

51+ Utf8.fromPtr

52+

53+

54+fromChars :: [Char] -> String

55+fromChars =

56+ Utf8.fromChars

57+

58+

59+fromSnippet :: P.Snippet -> String

60+fromSnippet =

61+ Utf8.fromSnippet

62+

63+

64+fromName :: Name.Name -> String

65+fromName =

66+ Coerce.coerce

67+

68+

69+

70+-- TO

71+

72+

73+toChars :: String -> [Char]

74+toChars =

75+ Utf8.toChars

76+

77+

78+{-# INLINE toBuilder #-}

79+toBuilder :: String -> B.Builder

80+toBuilder =

81+ Utf8.toBuilder

82+

83+

84+

85+-- FROM COMMENT

86+

87+

88+fromComment :: P.Snippet -> String

89+fromComment (P.Snippet fptr off len _ _) =

90+ unsafePerformIO $ withForeignPtr fptr $ \ptr ->

91+ let

92+ !pos = plusPtr ptr off

93+ !end = plusPtr pos len

94+ !str = fromChunks (chompChunks pos end pos [])

95+ in

96+ return str

97+

98+

99+chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

100+chompChunks pos end start revChunks =

101+ if pos >= end then

102+ reverse (addSlice start end revChunks)

103+ else

104+ let

105+ !word = P.unsafeIndex pos

106+ in

107+ case word of

108+ 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks

109+ 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks

110+ 0x27 {-'-} -> chompEscape 0x27 {-'-} pos end start revChunks

111+ 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks

112+ 0x0D {-\r-} ->

113+ let

114+ !newPos = plusPtr pos 1

115+ in

116+ chompChunks newPos end newPos (addSlice start pos revChunks)

117+

118+ _ ->

119+ let

120+ !width = P.getCharWidth pos end word

121+ !newPos = plusPtr pos width

122+ in

123+ chompChunks newPos end start revChunks

124+

125+

126+chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

127+chompEscape escape pos end start revChunks =

128+ let

129+ !pos1 = plusPtr pos 1

130+ in

131+ chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks)

132+

133+

134+addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

135+addSlice start end revChunks =

136+ if start == end

137+ then revChunks

138+ else Slice start (minusPtr end start) : revChunks

139+

140+

141+

142+-- FROM CHUNKS

143+

144+

145+data Chunk

146+ = Slice (Ptr Word8) Int

147+ | Escape Word8

148+

149+

150+fromChunks :: [Chunk] -> String

151+fromChunks chunks =

152+ unsafeDupablePerformIO (stToIO (

153+ do let !len = sum (map chunkToWidth chunks)

154+ mba <- newByteArray len

155+ writeChunks mba 0 chunks

156+ freeze mba

157+ ))

158+

159+

160+chunkToWidth :: Chunk -> Int

161+chunkToWidth chunk =

162+ case chunk of

163+ Slice _ len -> len

164+ Escape _ -> 2

165+

166+

167+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()

168+writeChunks mba offset chunks =

169+ case chunks of

170+ [] ->

171+ return ()

172+

173+ chunk : chunks ->

174+ case chunk of

175+ Slice ptr len ->

176+ do copyFromPtr ptr mba offset len

177+ let !newOffset = offset + len

178+ writeChunks mba newOffset chunks

179+

180+ Escape word ->

181+ do writeWord8 mba offset 0x5C {- \ -}

182+ writeWord8 mba (offset + 1) word

183+ let !newOffset = offset + 2

184+ writeChunks mba newOffset chunks