git.iko.soy/elk
on master help sign in
Introduce many distinct "string" types to help ensure appropriate escaping on code gen

I initially made the new (Utf8 size tipe) type with the idea that the crucial distinction was how the Binary code is generated (with a Word8 length or a Word64 length) and that there was some value in distinguishing types of strings a bit more than that. The new (Utf8 tipe) gets rid of the concept of size. That module now serves as a collection of helpers that are exposed through modules like Elm.String and Json.String. In this world, each particular (Utf8 ELM_STRING) or (Utf8 JSON_STRING) decides individually if it should have a binary instance at all. In the case of JSON_STRING, there shouldn't be one. If it is getting serialized, it is probably a bug or a mistake! Similarly, I can expose a really minimal API for each individual type of String. In cases like (Utf8 ELM_NAME) you know it's safe to generate them directly based on parser invariants. No need to escape anything. Whereas with turning a documentation comment into a (Utf8 JSON_STRING) you actually need to escape newlines, so allocation needs some extra checks and logic. Point is, the new setup should make it harder to make mistakes! (It actually caught one in Elm.Package by distinguishing AUTHOR and PROJECT. That'll be checked in later though!)

commit2b724719b21f3a498c7851152a7b68ef54b411ba authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 3 Jun 2019, 10:41 (7 years ago) parent14af98c
5 files changed+624−411
compare with master
unifiedsplit
compiler/src/Data/Name.hs+106−117 compiler/src/Data/Utf8.hs+149−294 compiler/src/Elm/Float.hs+51 compiler/src/Elm/String.hs+134 compiler/src/Json/String.hs+184
compiler/src/Data/Name.hs+106−117
@@ -1,17 +1,18 @@
11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
33module Data.Name
44 ( Name
5− , toUtf8
6− , fromUtf8
7− , toEscapedBuilder
8− , Utf8.toBuilder
9− , Utf8.fromPtr
10− , Utf8.fromChars
11− , Utf8.toChars
12− -- misc
5+ --
6+ , toChars
7+ , toElmString
8+ , toBuilder
9+ --
10+ , fromPtr
11+ , fromChars
12+ --
1313 , getKernel
1414 , hasDot
15+ , splitDots
1516 , isKernel
1617 , isNumberType
1718 , isComparableType
@@ -24,13 +25,13 @@ module Data.Name
2425 , fromTypeVariable
2526 , fromTypeVariableScheme
2627 , sepBy
27− -- interned
28+ --
2829 , int, float, bool, char, string
2930 , maybe, result, list, array, dict, tuple, jsArray
3031 , task, router, cmd, sub, platform, virtualDom
3132 , shader, debug, debugger, bitwise, basics
3233 , utils, negate, true, false, value
33− , node, program, main, dollar, identity
34+ , node, program, _main, _Main, dollar, identity
3435 , replModule
3536 )
3637 where
@@ -38,9 +39,11 @@ module Data.Name
3839
3940import Prelude hiding (length, maybe, negate)
4041import Control.Exception (assert)
42+import qualified Data.Binary as Binary
4143import qualified Data.ByteString.Builder.Internal as B
42−import Data.Coerce (coerce)
44+import qualified Data.Coerce as Coerce
4345import qualified Data.List as List
46+import qualified Data.String as Chars
4447import qualified Data.Utf8 as Utf8
4548import Foreign.Ptr (plusPtr, minusPtr)
4649import GHC.Exts
@@ -59,72 +62,64 @@ import GHC.ST (ST(ST), runST)
5962import GHC.Prim
6063import GHC.Word (Word8(W8#))
6164
65+import qualified Elm.String as ES
66+
6267
6368
6469-- NAME
6570
6671
67−type Name = Utf8.Under256 NAME
72+type Name =
73+ Utf8.Utf8 ELM_NAME
6874
6975
70−data NAME
76+data ELM_NAME
7177
7278
73−toUtf8 :: Name -> Utf8.String
74−toUtf8 =
75− coerce
7679
80+-- INSTANCES
7781
78−fromUtf8 :: Utf8.String -> Name
79−fromUtf8 =
80− coerce
8182
83+instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
84+ fromString = Utf8.fromChars
8285
86+instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
87+ get = Utf8.getUnder256
88+ put = Utf8.putUnder256
8389
84−-- TO ESCAPED BUILDER
8590
8691
87−{-# INLINE toEscapedBuilder #-}
88−toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder
89−toEscapedBuilder before after =
90− \name -> B.builder (toEscapedBuilderHelp before after name)
92+-- TO
9193
9294
93−{-# INLINE toEscapedBuilderHelp #-}
94−toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
95−toEscapedBuilderHelp before after !name@(Utf8.Utf8 ba#) k =
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)
95+toChars :: Name -> [Char]
96+toChars =
97+ Utf8.toChars
12598
126− else
127− return ()
99+
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
128123
129124
130125
@@ -133,7 +128,12 @@ escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) l
133128
134129hasDot :: Name -> Bool
135130hasDot 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
137137
138138
139139
@@ -181,23 +181,23 @@ isCompappendType = Utf8.startsWith prefix_compappend
181181
182182{-# NOINLINE prefix_kernel #-}
183183prefix_kernel :: Name
184−prefix_kernel = "Elm.Kernel."
184+prefix_kernel = fromChars "Elm.Kernel."
185185
186186{-# NOINLINE prefix_number #-}
187187prefix_number :: Name
188−prefix_number = "number"
188+prefix_number = fromChars "number"
189189
190190{-# NOINLINE prefix_comparable #-}
191191prefix_comparable :: Name
192−prefix_comparable = "comparable"
192+prefix_comparable = fromChars "comparable"
193193
194194{-# NOINLINE prefix_appendable #-}
195195prefix_appendable :: Name
196−prefix_appendable = "appendable"
196+prefix_appendable = fromChars "appendable"
197197
198198{-# NOINLINE prefix_compappend #-}
199199prefix_compappend :: Name
200−prefix_compappend = "compappend"
200+prefix_compappend = fromChars "compappend"
201201
202202
203203
@@ -423,22 +423,6 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
423423 s -> (# s, () #)
424424
425425
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−
442426{-# INLINE copyToMBA #-}
443427copyToMBA :: Name -> MBA s -> ST s ()
444428copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
@@ -453,169 +437,174 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
453437
454438{-# NOINLINE int #-}
455439int :: Name
456−int = "Int"
440+int = fromChars "Int"
457441
458442
459443{-# NOINLINE float #-}
460444float :: Name
461−float = "Float"
445+float = fromChars "Float"
462446
463447
464448{-# NOINLINE bool #-}
465449bool :: Name
466−bool = "Bool"
450+bool = fromChars "Bool"
467451
468452
469453{-# NOINLINE char #-}
470454char :: Name
471−char = "Char"
455+char = fromChars "Char"
472456
473457
474458{-# NOINLINE string #-}
475459string :: Name
476−string = "String"
460+string = fromChars "String"
477461
478462
479463{-# NOINLINE maybe #-}
480464maybe :: Name
481−maybe = "Maybe"
465+maybe = fromChars "Maybe"
482466
483467
484468{-# NOINLINE result #-}
485469result :: Name
486−result = "Result"
470+result = fromChars "Result"
487471
488472
489473{-# NOINLINE list #-}
490474list :: Name
491−list = "List"
475+list = fromChars "List"
492476
493477
494478{-# NOINLINE array #-}
495479array :: Name
496−array = "Array"
480+array = fromChars "Array"
497481
498482
499483{-# NOINLINE dict #-}
500484dict :: Name
501−dict = "Dict"
485+dict = fromChars "Dict"
502486
503487
504488{-# NOINLINE tuple #-}
505489tuple :: Name
506−tuple = "Tuple"
490+tuple = fromChars "Tuple"
507491
508492
509493{-# NOINLINE jsArray #-}
510494jsArray :: Name
511−jsArray = "JsArray"
495+jsArray = fromChars "JsArray"
512496
513497
514498{-# NOINLINE task #-}
515499task :: Name
516−task = "Task"
500+task = fromChars "Task"
517501
518502
519503{-# NOINLINE router #-}
520504router :: Name
521−router = "Router"
505+router = fromChars "Router"
522506
523507
524508{-# NOINLINE cmd #-}
525509cmd :: Name
526−cmd = "Cmd"
510+cmd = fromChars "Cmd"
527511
528512
529513{-# NOINLINE sub #-}
530514sub :: Name
531−sub = "Sub"
515+sub = fromChars "Sub"
532516
533517
534518{-# NOINLINE platform #-}
535519platform :: Name
536−platform = "Platform"
520+platform = fromChars "Platform"
537521
538522
539523{-# NOINLINE virtualDom #-}
540524virtualDom :: Name
541−virtualDom = "VirtualDom"
525+virtualDom = fromChars "VirtualDom"
542526
543527
544528{-# NOINLINE shader #-}
545529shader :: Name
546−shader = "Shader"
530+shader = fromChars "Shader"
547531
548532
549533{-# NOINLINE debug #-}
550534debug :: Name
551−debug = "Debug"
535+debug = fromChars "Debug"
552536
553537
554538{-# NOINLINE debugger #-}
555539debugger :: Name
556−debugger = "Debugger"
540+debugger = fromChars "Debugger"
557541
558542
559543{-# NOINLINE bitwise #-}
560544bitwise :: Name
561−bitwise = "Bitwise"
545+bitwise = fromChars "Bitwise"
562546
563547
564548{-# NOINLINE basics #-}
565549basics :: Name
566−basics = "Basics"
550+basics = fromChars "Basics"
567551
568552
569553{-# NOINLINE utils #-}
570554utils :: Name
571−utils = "Utils"
555+utils = fromChars "Utils"
572556
573557
574558{-# NOINLINE negate #-}
575559negate :: Name
576−negate = "negate"
560+negate = fromChars "negate"
577561
578562
579563{-# NOINLINE true #-}
580564true :: Name
581−true = "True"
565+true = fromChars "True"
582566
583567
584568{-# NOINLINE false #-}
585569false :: Name
586−false = "False"
570+false = fromChars "False"
587571
588572
589573{-# NOINLINE value #-}
590574value :: Name
591−value = "Value"
575+value = fromChars "Value"
592576
593577
594578{-# NOINLINE node #-}
595579node :: Name
596−node = "Node"
580+node = fromChars "Node"
597581
598582
599583{-# NOINLINE program #-}
600584program :: Name
601−program = "Program"
585+program = fromChars "Program"
586+
587+
588+{-# NOINLINE _main #-}
589+_main :: Name
590+_main = fromChars "main"
602591
603592
604−{-# NOINLINE main #-}
605−main :: Name
606−main = "main"
593+{-# NOINLINE _Main #-}
594+_Main :: Name
595+_Main = fromChars "Main"
607596
608597
609598{-# NOINLINE dollar #-}
610599dollar :: Name
611−dollar = "$"
600+dollar = fromChars "$"
612601
613602
614603{-# NOINLINE identity #-}
615604identity :: Name
616−identity = "identity"
605+identity = fromChars "identity"
617606
618607
619608{-# NOINLINE replModule #-}
620609replModule :: Name
621−replModule = "Elm_Repl"
610+replModule = fromChars "Elm_Repl"
compiler/src/Data/Utf8.hs+149−294
@@ -1,37 +1,42 @@
11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}
33module Data.Utf8
4− ( String
5− , Utf8(..)
6− , VeryLong
7− , Under256
4+ ( Utf8(..)
85 , isEmpty
96 , empty
107 , size
118 , contains
12− , containsDouble
139 , startsWith
1410 , startsWithChar
15− , endsWithWord
11+ , endsWithWord8
1612 , split
1713 , join
18− , all
19− , any
20− , toWord16
21− , fromWord16
22− -- conversions
23− , fromChars
14+ --
15+ , getUnder256
16+ , putUnder256
17+ --
18+ , getVeryLong
19+ , putVeryLong
20+ --
2421 , toChars
2522 , toBuilder
23+ , toEscapedBuilder
24+ --
2625 , fromPtr
27− , fromChunks
28− , Chunk(..)
26+ , fromSnippet
27+ , fromChars
28+ --
29+ , MBA
30+ , newByteArray
31+ , copyFromPtr
32+ , writeWord8
33+ , freeze
2934 )
3035 where
3136
3237
3338import Prelude hiding (String, all, any, concat)
34−import Data.Binary (Binary(..), Get, getWord8, putWord8)
39+import Data.Binary (Get, get, getWord8, Put, put, putWord8)
3540import Data.Binary.Put (putBuilder)
3641import Data.Binary.Get.Internal (readN)
3742import Data.Bits ((.&.), shiftR)
@@ -39,7 +44,6 @@ import qualified Data.ByteString.Internal as B
3944import qualified Data.ByteString.Builder.Internal as B
4045import qualified Data.Char as Char
4146import qualified Data.List as List
42−import Data.String (IsString(..))
4347import Foreign.ForeignPtr (touchForeignPtr)
4448import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
4549import Foreign.Ptr (minusPtr, plusPtr)
@@ -54,36 +58,35 @@ import GHC.Exts
5458 , copyByteArray#
5559 , copyAddrToByteArray#
5660 , copyByteArrayToAddr#
57− , writeWord8Array#,
61+ , writeWord8Array#
5862 )
5963import GHC.IO
6064import GHC.ST (ST(ST), runST)
6165import GHC.Prim
6266import GHC.Word (Word8(W8#), Word16(W16#))
6367
68+import qualified Parse.Primitives as P
69+
6470
6571
6672-- UTF-8
6773
6874
69−data Utf8 size tipe =
75+data Utf8 tipe =
7076 Utf8 ByteArray#
7177
7278
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
8079
80+-- EMPTY
8181
8282
83−-- IS EMPTY
83+{-# NOINLINE empty #-}
84+empty :: Utf8 t
85+empty =
86+ runST (freeze =<< newByteArray 0)
8487
8588
86−isEmpty :: Utf8 l t -> Bool
89+isEmpty :: Utf8 t -> Bool
8790isEmpty (Utf8 ba#) =
8891 isTrue# (sizeofByteArray# ba# ==# 0#)
8992
@@ -92,7 +95,7 @@ isEmpty (Utf8 ba#) =
9295-- SIZE
9396
9497
95−size :: Utf8 l t -> Int
98+size :: Utf8 t -> Int
9699size (Utf8 ba#) =
97100 I# (sizeofByteArray# ba#)
98101
@@ -101,7 +104,7 @@ size (Utf8 ba#) =
101104-- CONTAINS
102105
103106
104−contains :: Word8 -> Utf8 l t -> Bool
107+contains :: Word8 -> Utf8 t -> Bool
105108contains (W8# word#) (Utf8 ba#) =
106109 containsHelp word# ba# 0# (sizeofByteArray# ba#)
107110
@@ -117,32 +120,11 @@ containsHelp word# ba# !offset# len# =
117120
118121
119122
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−
141123-- STARTS WITH
142124
143125
144126{-# INLINE startsWith #-}
145−startsWith :: Utf8 l t -> Utf8 l t -> Bool
127+startsWith :: Utf8 t -> Utf8 t -> Bool
146128startsWith (Utf8 ba1#) (Utf8 ba2#) =
147129 let
148130 !len1# = sizeofByteArray# ba1#
@@ -157,9 +139,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =
157139-- STARTS WITH CHAR
158140
159141
160−startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool
161−startsWithChar isGood str@(Utf8 ba#) =
162− if isEmpty str then
142+startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool
143+startsWithChar isGood bytes@(Utf8 ba#) =
144+ if isEmpty bytes then
163145 False
164146 else
165147 let
@@ -177,8 +159,8 @@ startsWithChar isGood str@(Utf8 ba#) =
177159-- ENDS WITH WORD
178160
179161
180−endsWithWord :: Word8 -> Utf8 l t -> Bool
181−endsWithWord (W8# w#) (Utf8 ba#) =
162+endsWithWord8 :: Word8 -> Utf8 t -> Bool
163+endsWithWord8 (W8# w#) (Utf8 ba#) =
182164 let len# = sizeofByteArray# ba# in
183165 isTrue# (len# ># 0#)
184166 &&
@@ -189,12 +171,12 @@ endsWithWord (W8# w#) (Utf8 ba#) =
189171-- SPLIT
190172
191173
192−split :: Word8 -> String -> [String]
174+split :: Word8 -> Utf8 t -> [Utf8 t]
193175split (W8# divider#) str@(Utf8 ba#) =
194176 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
195177
196178
197−splitHelp :: String -> Int -> [Int] -> [String]
179+splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]
198180splitHelp str start offsets =
199181 case offsets of
200182 [] ->
@@ -215,7 +197,7 @@ findDividers divider# ba# !offset# len# revOffsets =
215197 reverse revOffsets
216198
217199
218−unsafeSlice :: String -> Int -> Int -> String
200+unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t
219201unsafeSlice str start end =
220202 let !len = end - start in
221203 if len == 0 then
@@ -231,7 +213,7 @@ unsafeSlice str start end =
231213-- JOIN
232214
233215
234−join :: Word8 -> [String] -> String
216+join :: Word8 -> [Utf8 t] -> Utf8 t
235217join sep strings =
236218 case strings of
237219 [] ->
@@ -245,7 +227,7 @@ join sep strings =
245227 freeze mba
246228
247229
248−joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()
230+joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()
249231joinHelp sep mba offset str strings =
250232 let
251233 !len = size str
@@ -263,46 +245,10 @@ joinHelp sep mba offset str strings =
263245
264246
265247
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−
302248-- EQUAL
303249
304250
305−instance Eq (Utf8 l t) where
251+instance Eq (Utf8 t) where
306252 (==) (Utf8 ba1#) (Utf8 ba2#) =
307253 let
308254 !len1# = sizeofByteArray# ba1#
@@ -317,7 +263,7 @@ instance Eq (Utf8 l t) where
317263-- COMPARE
318264
319265
320−instance Ord (Utf8 l t) where
266+instance Ord (Utf8 t) where
321267 compare (Utf8 ba1#) (Utf8 ba2#) =
322268 let
323269 !len1# = sizeofByteArray# ba1#
@@ -334,84 +280,20 @@ instance Ord (Utf8 l t) where
334280
335281
336282
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−
396283-- FROM STRING
397284
398285
399−fromChars :: [Char] -> Utf8 l t
400−fromChars =
401− fromString
402−
403−
404−instance IsString (Utf8 l t) where
405− fromString str =
406− runST
407− (
408− do mba <- newByteArray (sum (map getWidth str))
409− writeString mba 0 str
410− )
286+fromChars :: [Char] -> Utf8 t
287+fromChars chars =
288+ runST
289+ (
290+ do mba <- newByteArray (sum (map getWidth chars))
291+ writeChars mba 0 chars
292+ )
411293
412294
413−writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)
414−writeString !mba !offset chars =
295+writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)
296+writeChars !mba !offset chars =
415297 case chars of
416298 [] ->
417299 freeze mba
@@ -419,25 +301,25 @@ writeString !mba !offset chars =
419301 char : chars
420302 | n < 0x80 ->
421303 do writeWord8 mba (offset ) (fromIntegral n)
422− writeString mba (offset + 1) chars
304+ writeChars mba (offset + 1) chars
423305
424306 | n < 0x800 ->
425307 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
426308 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
427− writeString mba (offset + 2) chars
309+ writeChars mba (offset + 2) chars
428310
429311 | n < 0x10000 ->
430312 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
431313 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
432314 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
433− writeString mba (offset + 3) chars
315+ writeChars mba (offset + 3) chars
434316
435317 | otherwise ->
436318 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
437319 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
438320 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
439321 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
440− writeString mba (offset + 4) chars
322+ writeChars mba (offset + 4) chars
441323
442324 where
443325 n = Char.ord char
@@ -455,10 +337,10 @@ getWidth char
455337
456338
457339
458−-- TO STRING
340+-- TO CHARS
459341
460342
461−toChars :: Utf8 l t -> [Char]
343+toChars :: Utf8 t -> [Char]
462344toChars (Utf8 ba#) =
463345 toCharsHelp ba# 0# (sizeofByteArray# ba#)
464346
@@ -528,13 +410,13 @@ chr4 ba# offset# firstWord# =
528410
529411
530412{-# INLINE toBuilder #-}
531−toBuilder :: Utf8 l t -> B.Builder
413+toBuilder :: Utf8 t -> B.Builder
532414toBuilder =
533415 \bytes -> B.builder (toBuilderHelp bytes)
534416
535417
536418{-# INLINE toBuilderHelp #-}
537−toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a
419+toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a
538420toBuilderHelp !bytes@(Utf8 ba#) k =
539421 go 0 (I# (sizeofByteArray# ba#))
540422 where
@@ -554,144 +436,109 @@ toBuilderHelp !bytes@(Utf8 ba#) k =
554436
555437
556438
557−-- FROM PTR
439+-- TO ESCAPED BUILDER
558440
559441
560−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t
561−fromPtr pos end =
562− unsafeDupablePerformIO (stToIO (
563− do let !len = minusPtr end pos
564− mba <- newByteArray len
565− copyFromPtr pos mba 0 len
566− freeze mba
567− ))
442+{-# INLINE toEscapedBuilder #-}
443+toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder
444+toEscapedBuilder before after =
445+ \name -> B.builder (toEscapedBuilderHelp before after name)
568446
569447
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 ()
570483
571−-- FROM CHUNKS
572484
573485
574−data Chunk
575− = Slice (Ptr Word8) Int
576− | Escape Word8
577− | CodePoint Int
486+-- FROM PTR
578487
579488
580−fromChunks :: [Chunk] -> Utf8 l t
581−fromChunks chunks =
489+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t
490+fromPtr pos end =
582491 unsafeDupablePerformIO (stToIO (
583− do let !len = sum (map chunkToWidth chunks)
492+ do let !len = minusPtr end pos
584493 mba <- newByteArray len
585− writeChunks mba 0 chunks
494+ copyFromPtr pos mba 0 len
586495 freeze mba
587496 ))
588497
589498
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)
650499
500+-- FROM SNIPPET
651501
652502
653−-- UNDER 256 BINARY
654−
655−
656−instance Binary (Utf8 UNDER_256 t) where
657− put bytes@(Utf8 ba#) =
658− do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
659− putBuilder (toBuilder bytes)
660− get =
661− getUnder256 =<< getWord8
503+fromSnippet :: P.Snippet -> Utf8 t
504+fromSnippet (P.Snippet fptr off len _ _) =
505+ unsafeDupablePerformIO (stToIO (
506+ do mba <- newByteArray len
507+ let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off
508+ copyFromPtr pos mba 0 len
509+ freeze mba
510+ ))
662511
663512
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)
669513
514+-- BINARY
670515
671516
672−-- VERY LONG BINARY
517+putUnder256 :: Utf8 t -> Put
518+putUnder256 bytes =
519+ do putWord8 (fromIntegral (size bytes))
520+ putBuilder (toBuilder bytes)
673521
674522
675−instance Binary (Utf8 VERY_LONG t) where
676− put str =
677− do put (size str)
678− putBuilder (toBuilder str)
679− get =
680− getVeryLong =<< get
523+getUnder256 :: Get (Utf8 t)
524+getUnder256 =
525+ do word <- getWord8
526+ let !n = fromIntegral word
527+ readN n (copyFromByteString n)
681528
682529
683−{-# INLINE getVeryLong #-}
684−getVeryLong :: Int -> Get (Utf8 VERY_LONG t)
685−getVeryLong n =
686− if n > 0
687− then readN n (copyFromByteString n)
688− else return empty
530+putVeryLong :: Utf8 t -> Put
531+putVeryLong bytes =
532+ do put (size bytes)
533+ putBuilder (toBuilder bytes)
689534
690535
691−{-# NOINLINE empty #-}
692−empty :: Utf8 l t
693−empty =
694− runST (freeze =<< newByteArray 0)
536+getVeryLong :: Get (Utf8 t)
537+getVeryLong =
538+ do n <- get
539+ if n > 0
540+ then readN n (copyFromByteString n)
541+ else return empty
695542
696543
697544
@@ -699,7 +546,7 @@ empty =
699546
700547
701548{-# INLINE copyFromByteString #-}
702−copyFromByteString :: Int -> B.ByteString -> Utf8 l t
549+copyFromByteString :: Int -> B.ByteString -> Utf8 t
703550copyFromByteString len (B.PS fptr offset _) =
704551 unsafeDupablePerformIO
705552 (
@@ -725,14 +572,14 @@ newByteArray (I# len#) =
725572 (# s, mba# #) -> (# s, MBA# mba# #)
726573
727574
728−freeze :: MBA s -> ST s (Utf8 l t)
575+freeze :: MBA s -> ST s (Utf8 t)
729576freeze (MBA# mba#) =
730577 ST $ \s ->
731578 case unsafeFreezeByteArray# mba# s of
732579 (# s, ba# #) -> (# s, Utf8 ba# #)
733580
734581
735−copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()
582+copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()
736583copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
737584 ST $ \s ->
738585 case copyByteArray# ba# offset# mba# i# len# s of
@@ -746,7 +593,7 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
746593 s -> (# s, () #)
747594
748595
749−copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()
596+copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()
750597copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
751598 IO $ \s ->
752599 case copyByteArrayToAddr# ba# offset# mba# len# s of
@@ -759,3 +606,11 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
759606 ST $ \s ->
760607 case writeWord8Array# mba# offset# w# s of
761608 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
9+
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