@@ -0,0 +1,814 @@
1+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
3+module Data.Name
4+ ( Name
5+ , length
6+ , toUtf8
7+ , toBuilder
8+ , toEscapedBuilder
9+ , fromByteString
10+ , fromString
11+ -- ???
12+ , toText
13+ , toString
14+ , getKernel
15+ , isKernel
16+ , hasDot
17+ , isNumberType
18+ , isComparableType
19+ , isAppendableType
20+ , isCompappendType
21+ , fromVarIndex
22+ , fromWords
23+ , fromManyNames
24+ , fromTypeVariable
25+ , fromTypeVariableScheme
26+ , sepBy
27+ -- interned
28+ , int, float, bool, char, string
29+ , maybe, result, list, array, dict, tuple, jsArray
30+ , task, router, cmd, sub, platform, virtualDom
31+ , shader, debug, debugger, bitwise, basics
32+ , utils, negate, true, false, value
33+ , node, program, main, dollar, identity
34+ , replModule
35+ )
36+ where
37+
38+
39+import Control.Exception (assert)
40+import Data.Binary (Binary(..), Get, getWord8, putWord8)
41+import Data.Binary.Put (putBuilder)
42+import Data.Binary.Get.Internal (readN)
43+import qualified Data.ByteString.Internal as B
44+import qualified Data.ByteString.Builder.Internal as B
45+import qualified Data.List as List
46+import Data.String (IsString(..))
47+import qualified Data.Text as Text
48+import qualified Data.Utf8 as Utf8
49+import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
50+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
51+import Foreign.Ptr (minusPtr, plusPtr)
52+import GHC.Exts
53+ ( Int(I#), Ptr(Ptr), Char(C#)
54+ , RealWorld
55+ , ByteArray#, MutableByteArray#
56+ , isTrue#
57+ , newByteArray#, unsafeFreezeByteArray#
58+ , sizeofByteArray#
59+ , writeCharArray#, writeWord8OffAddr#
60+ , copyAddrToByteArray#, copyByteArrayToAddr#
61+ )
62+import GHC.IO
63+import GHC.ST (ST(ST), runST)
64+import GHC.Prim
65+import GHC.Word (Word8(W8#))
66+import Prelude hiding (length, maybe, negate)
67+
68+
69+
70+-- UTF-8
71+
72+
73+data Name =
74+ Name ByteArray#
75+
76+
77+
78+-- LENGTH
79+
80+
81+length :: Name -> Int
82+length (Name ba#) =
83+ I# (sizeofByteArray# ba#)
84+
85+
86+
87+-- EQUAL
88+
89+
90+instance Eq Name where
91+ (==) (Name ba1#) (Name ba2#) =
92+ let
93+ !len1# = sizeofByteArray# ba1#
94+ !len2# = sizeofByteArray# ba2#
95+ in
96+ isTrue# (len1# ==# len2#)
97+ &&
98+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
99+
100+
101+
102+-- COMPARE
103+
104+
105+-- TODO see if this can be written any faster
106+instance Ord Name where
107+ compare (Name ba1#) (Name ba2#) =
108+ let
109+ !len1# = sizeofByteArray# ba1#
110+ !len2# = sizeofByteArray# ba2#
111+ !len# = if isTrue# (len1# <# len2#) then len1# else len2#
112+ !cmp# = compareByteArrays# ba1# 0# ba2# 0# len#
113+ in
114+ case () of
115+ _ | isTrue# (cmp# <# 0#) -> LT
116+ | isTrue# (cmp# ># 0#) -> GT
117+ | isTrue# (len1# <# len2#) -> LT
118+ | isTrue# (len1# ># len2#) -> GT
119+ | True -> EQ
120+
121+
122+
123+-- STRING OVERLOADING
124+
125+
126+instance IsString Name where
127+ fromString str =
128+ runST
129+ (
130+ do mba <- newByteArray (List.length str)
131+ writeChars mba 0 str
132+ unsafeFreeze mba
133+ )
134+
135+
136+writeChars :: MBA s -> Int -> [Char] -> ST s ()
137+writeChars !mba !i chars =
138+ case chars of
139+ [] ->
140+ return ()
141+
142+ c:cs ->
143+ do writeChar8 mba i c
144+ writeChars mba (i+1) cs
145+
146+
147+
148+-- BINARY
149+
150+
151+instance Binary Name where
152+ put name@(Name ba#) =
153+ putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
154+ >> putBuilder (toBuilder name)
155+ get =
156+ getWord8 >>= getName
157+
158+
159+{-# INLINE getName #-}
160+getName :: Word8 -> Get Name
161+getName w =
162+ let !n = fromIntegral w in
163+ readN n (copyFromByteString n)
164+
165+
166+{-# INLINE copyFromByteString #-}
167+copyFromByteString :: Int -> B.ByteString -> Name
168+copyFromByteString len (B.PS fptr offset _) =
169+ unsafeDupablePerformIO
170+ (
171+ do mba <- stToIO (newByteArray len)
172+ stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)
173+ touchForeignPtr fptr
174+ stToIO (unsafeFreeze mba)
175+ )
176+
177+
178+
179+-- FROM BYTESTRING
180+
181+
182+fromByteString :: ForeignPtr Word8 -> Int -> Int -> Name
183+fromByteString fptr offset len =
184+ unsafeDupablePerformIO
185+ (
186+ do mba <- stToIO (newByteArray len)
187+ stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)
188+ touchForeignPtr fptr
189+ stToIO (unsafeFreeze mba)
190+ )
191+
192+
193+
194+-- TO UTF-8
195+
196+
197+{-# INLINE toUtf8 #-}
198+toUtf8 :: Name -> Utf8.Utf8
199+toUtf8 (Name ba#) =
200+ Utf8.Utf8 ba#
201+
202+
203+
204+-- TO BUILDER
205+
206+
207+{-# INLINE toBuilder #-}
208+toBuilder :: Name -> B.Builder
209+toBuilder =
210+ \name -> B.builder (toBuilderHelp name)
211+
212+
213+{-# INLINE toBuilderHelp #-}
214+toBuilderHelp :: Name -> B.BuildStep a -> B.BuildStep a
215+toBuilderHelp !name@(Name ba#) k =
216+ go 0 (I# (sizeofByteArray# ba#))
217+ where
218+ go !offset !end !(B.BufferRange bOffset bEnd) =
219+ let
220+ !bLen = minusPtr bEnd bOffset
221+ !len = end - offset
222+ in
223+ if len <= bLen then
224+ do stToIO (copyToPtr name offset bOffset len)
225+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
226+ k newBufferRange
227+ else
228+ do stToIO (copyToPtr name offset bOffset bLen)
229+ let !newOffset = offset + bLen
230+ return $ B.bufferFull 1 bEnd (go newOffset end)
231+
232+
233+
234+-- TO ESCAPED BUILDER
235+
236+
237+{-# INLINE toEscapedBuilder #-}
238+toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder
239+toEscapedBuilder before after =
240+ \name -> B.builder (toEscapedBuilderHelp before after name)
241+
242+
243+{-# INLINE toEscapedBuilderHelp #-}
244+toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
245+toEscapedBuilderHelp before after !name@(Name ba#) k =
246+ go 0 (I# (sizeofByteArray# ba#))
247+ where
248+ go !offset !len !(B.BufferRange bOffset bEnd) =
249+ let
250+ !bLen = minusPtr bEnd bOffset
251+ in
252+ if len <= bLen then
253+ do -- TODO test if writing word-by-word is faster
254+ stToIO (copyToPtr name offset bOffset len)
255+ stToIO (escape before after bOffset name offset len)
256+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
257+ k newBufferRange
258+ else
259+ do stToIO (copyToPtr name offset bOffset bLen)
260+ stToIO (escape before after bOffset name offset bLen)
261+ let !newOffset = offset + bLen
262+ let !newLength = len - bLen
263+ return $ B.bufferFull 1 bEnd (go newOffset newLength)
264+
265+
266+escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> ST RealWorld ()
267+escape before@(W8# before#) after ptr name@(Name ba#) offset@(I# offset#) end@(I# end#) =
268+ if isTrue# (offset# <# end#) then
269+ if isTrue# (eqWord# before# (indexWord8Array# ba# offset#))
270+ then
271+ do writeWordToPtr ptr offset after
272+ escape before after ptr name (offset + 1) end
273+ else
274+ do escape before after ptr name (offset + 1) end
275+
276+ else
277+ return ()
278+
279+
280+
281+-- TO STRING
282+
283+
284+toString :: Name -> String
285+toString name =
286+ Utf8.toString (toUtf8 name)
287+
288+
289+
290+-- HAS DOT
291+
292+
293+hasDot :: Name -> Bool
294+hasDot (Name ba#) =
295+ let
296+ !len# = sizeofByteArray# ba#
297+ in
298+ hasDotHelp ba# 0# len#
299+
300+
301+hasDotHelp :: ByteArray# -> Int# -> Int# -> Bool
302+hasDotHelp ba# !offset# end# =
303+ if isTrue# (offset# <# end#) then
304+ if isTrue# (eqWord# 0x2E## {- . -} (indexWord8Array# ba# offset#))
305+ then True
306+ else hasDotHelp ba# (offset# +# 1#) end#
307+
308+ else
309+ False
310+
311+
312+
313+-- TO TEXT
314+
315+
316+toText :: Name -> Text.Text
317+toText name =
318+ Text.pack (toString name) -- TODO get rid of this?
319+
320+
321+
322+-- GET KERNEL
323+
324+
325+getKernel :: Name -> Name
326+getKernel name@(Name ba#) =
327+ assert (isKernel name)
328+ (
329+ runST
330+ (
331+ let
332+ !size# = sizeofByteArray# ba# -# 11#
333+ in
334+ ST $ \s ->
335+ case newByteArray# size# s of
336+ (# s, mba# #) ->
337+ case copyByteArray# ba# 11# mba# 0# size# s of
338+ s ->
339+ case unsafeFreezeByteArray# mba# s of
340+ (# s, ba# #) -> (# s, Name ba# #)
341+ )
342+ )
343+
344+
345+
346+-- STARTS WITH
347+
348+
349+{-# INLINE startsWith #-}
350+startsWith :: Name -> Name -> Bool
351+startsWith (Name ba1#) (Name ba2#) =
352+ let
353+ !len1# = sizeofByteArray# ba1#
354+ !len2# = sizeofByteArray# ba2#
355+ in
356+ isTrue# (len1# <=# len2#)
357+ &&
358+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
359+
360+
361+isKernel :: Name -> Bool
362+isKernel = startsWith prefix_kernel
363+
364+isNumberType :: Name -> Bool
365+isNumberType = startsWith prefix_number
366+
367+isComparableType :: Name -> Bool
368+isComparableType = startsWith prefix_comparable
369+
370+isAppendableType :: Name -> Bool
371+isAppendableType = startsWith prefix_appendable
372+
373+isCompappendType :: Name -> Bool
374+isCompappendType = startsWith prefix_compappend
375+
376+{-# NOINLINE prefix_kernel #-}
377+prefix_kernel :: Name
378+prefix_kernel = "Elm.Kernel."
379+
380+{-# NOINLINE prefix_number #-}
381+prefix_number :: Name
382+prefix_number = "number"
383+
384+{-# NOINLINE prefix_comparable #-}
385+prefix_comparable :: Name
386+prefix_comparable = "comparable"
387+
388+{-# NOINLINE prefix_appendable #-}
389+prefix_appendable :: Name
390+prefix_appendable = "appendable"
391+
392+{-# NOINLINE prefix_compappend #-}
393+prefix_compappend :: Name
394+prefix_compappend = "compappend"
395+
396+
397+
398+-- FROM INDEX
399+
400+
401+fromVarIndex :: Int -> Name
402+fromVarIndex n =
403+ runST
404+ (
405+ do let !size = getIndexSize n
406+ mba <- newByteArray size
407+ writeWord8 mba 0 0x5F {- _ -}
408+ writeWord8 mba 1 0x76 {- v -}
409+ writeNumbers mba (size - 1) n
410+ unsafeFreeze mba
411+ )
412+
413+
414+{-# INLINE getIndexSize #-}
415+getIndexSize :: Int -> Int
416+getIndexSize n
417+ | n < 10 = 3
418+ | n < 100 = 4
419+ | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)
420+
421+
422+
423+writeNumbers :: MBA s -> Int -> Int -> ST s ()
424+writeNumbers !mba !offset !n =
425+ do let (q,r) = quotRem n 10
426+ writeWord8 mba offset (0x30 + fromIntegral r)
427+ if q <= 0
428+ then return ()
429+ else writeNumbers mba (offset-1) q
430+
431+
432+fromTypeVariable :: Name -> Int -> Name
433+fromTypeVariable name@(Name ba#) index =
434+ if index <= 0 then
435+ name
436+ else
437+ let
438+ len# = sizeofByteArray# ba#
439+ end# = indexWord8Array# ba# (len# -# 1#)
440+ in
441+ if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then
442+ runST
443+ (
444+ do let !size = length name + 1 + getIndexSize index
445+ mba <- newByteArray size
446+ copyToMBA name mba
447+ writeWord8 mba (I# len#) 0x5F {- _ -}
448+ writeNumbers mba (size - 1) index
449+ unsafeFreeze mba
450+ )
451+ else
452+ runST
453+ (
454+ do let !size = length name + getIndexSize index
455+ mba <- newByteArray size
456+ copyToMBA name mba
457+ writeNumbers mba (size - 1) index
458+ unsafeFreeze mba
459+ )
460+
461+
462+fromTypeVariableScheme :: Int -> Name
463+fromTypeVariableScheme scheme =
464+ runST
465+ (
466+ if scheme < 26 then
467+ do mba <- newByteArray 1
468+ writeWord8 mba 0 (0x61 + fromIntegral scheme)
469+ unsafeFreeze mba
470+ else
471+ do let (extra, letter) = quotRem scheme 26
472+ let !size = getIndexSize extra
473+ mba <- newByteArray size
474+ writeWord8 mba 0 (0x61 + fromIntegral letter)
475+ writeNumbers mba (size - 1) extra
476+ unsafeFreeze mba
477+ )
478+
479+
480+
481+-- FROM MANY NAMES
482+
483+
484+fromManyNames :: [Name] -> Name
485+fromManyNames names =
486+ let
487+ !(I# size#) = sum (map (\(Name ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
488+ in
489+ runST
490+ (
491+ ST $ \s ->
492+ case newByteArray# size# s of
493+ (# s, mba# #) ->
494+ case writeNames mba# 0# names s of
495+ s ->
496+ case unsafeFreezeByteArray# mba# s of
497+ (# s, ba# #) -> (# s, Name ba# #)
498+ )
499+
500+
501+writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
502+writeNames mba# !offset# names s =
503+ case names of
504+ [] ->
505+ s
506+
507+ (Name ba#) : names ->
508+ case writeWord8Array# mba# offset# 0x24## {- $ -} s of
509+ s ->
510+ let
511+ !offset1# = offset# +# 1#
512+ !len# = sizeofByteArray# ba#
513+ !newOffset# = offset1# +# len#
514+ in
515+ case copyByteArray# ba# 0# mba# offset1# len# s of
516+ s ->
517+ writeNames mba# newOffset# names s
518+
519+
520+
521+-- FROM WORDS
522+
523+
524+fromWords :: [Word8] -> Name
525+fromWords words =
526+ runST
527+ (
528+ do mba <- newByteArray (List.length words)
529+ writeWords mba 0 words
530+ unsafeFreeze mba
531+ )
532+
533+
534+writeWords :: MBA s -> Int -> [Word8] -> ST s ()
535+writeWords !mba !i words =
536+ case words of
537+ [] ->
538+ return ()
539+
540+ w:ws ->
541+ do writeWord8 mba i w
542+ writeWords mba (i+1) ws
543+
544+
545+
546+-- SEP BY
547+
548+
549+sepBy :: Word8 -> Name -> Name -> Name
550+sepBy (W8# sep#) (Name ba1#) (Name ba2#) =
551+ let
552+ !len1# = sizeofByteArray# ba1#
553+ !len2# = sizeofByteArray# ba2#
554+ in
555+ runST
556+ (
557+ ST $ \s ->
558+ case newByteArray# (len1# +# len2# +# 1#) s of
559+ (# s, mba# #) ->
560+ case copyByteArray# ba1# 0# mba# 0# len1# s of
561+ s ->
562+ case writeWord8Array# mba# len1# sep# s of
563+ s ->
564+ case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of
565+ s ->
566+ case unsafeFreezeByteArray# mba# s of
567+ (# s, ba# #) -> (# s, Name ba# #)
568+ )
569+
570+
571+
572+-- PRIMITIVES
573+
574+
575+data MBA s =
576+ MBA# (MutableByteArray# s)
577+
578+
579+{-# INLINE newByteArray #-}
580+newByteArray :: Int -> ST s (MBA s)
581+newByteArray (I# len#) =
582+ ST $ \s ->
583+ case newByteArray# len# s of
584+ (# s, mba# #) -> (# s, MBA# mba# #)
585+
586+
587+{-# INLINE unsafeFreeze #-}
588+unsafeFreeze :: MBA s -> ST s Name
589+unsafeFreeze (MBA# mba#) =
590+ ST $ \s ->
591+ case unsafeFreezeByteArray# mba# s of
592+ (# s, ba# #) -> (# s, Name ba# #)
593+
594+
595+{-# INLINE writeChar8 #-}
596+writeChar8 :: MBA s -> Int -> Char -> ST s ()
597+writeChar8 (MBA# mba#) (I# offset#) (C# char#) =
598+ ST $ \s ->
599+ case writeCharArray# mba# offset# char# s of
600+ s -> (# s, () #)
601+
602+
603+{-# INLINE writeWord8 #-}
604+writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
605+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
606+ ST $ \s ->
607+ case writeWord8Array# mba# offset# w# s of
608+ s -> (# s, () #)
609+
610+
611+{-# INLINE writeWordToPtr #-}
612+writeWordToPtr :: Ptr a -> Int -> Word8 -> ST s ()
613+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
614+ ST $ \s ->
615+ case writeWord8OffAddr# addr# offset# word# s of
616+ s -> (# s, () #)
617+
618+
619+{-# INLINE copyFromPtr #-}
620+copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
621+copyFromPtr (Ptr addr#) (MBA# mba#) (I# offset#) (I# len#) =
622+ ST $ \s ->
623+ case copyAddrToByteArray# addr# mba# offset# len# s of
624+ s -> (# s, () #)
625+
626+
627+{-# INLINE copyToPtr #-}
628+copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()
629+copyToPtr (Name ba#) (I# offset#) (Ptr addr#) (I# len#) =
630+ ST $ \s ->
631+ case copyByteArrayToAddr# ba# offset# addr# len# s of
632+ s -> (# s, () #)
633+
634+
635+{-# INLINE copyToMBA #-}
636+copyToMBA :: Name -> MBA s -> ST s ()
637+copyToMBA (Name ba#) (MBA# mba#) =
638+ ST $ \s ->
639+ case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of
640+ s -> (# s, () #)
641+
642+
643+
644+-- COMMON NAMES
645+
646+
647+{-# NOINLINE int #-}
648+int :: Name
649+int = "Int"
650+
651+
652+{-# NOINLINE float #-}
653+float :: Name
654+float = "Float"
655+
656+
657+{-# NOINLINE bool #-}
658+bool :: Name
659+bool = "Bool"
660+
661+
662+{-# NOINLINE char #-}
663+char :: Name
664+char = "Char"
665+
666+
667+{-# NOINLINE string #-}
668+string :: Name
669+string = "String"
670+
671+
672+{-# NOINLINE maybe #-}
673+maybe :: Name
674+maybe = "Maybe"
675+
676+
677+{-# NOINLINE result #-}
678+result :: Name
679+result = "Result"
680+
681+
682+{-# NOINLINE list #-}
683+list :: Name
684+list = "List"
685+
686+
687+{-# NOINLINE array #-}
688+array :: Name
689+array = "Array"
690+
691+
692+{-# NOINLINE dict #-}
693+dict :: Name
694+dict = "Dict"
695+
696+
697+{-# NOINLINE tuple #-}
698+tuple :: Name
699+tuple = "Tuple"
700+
701+
702+{-# NOINLINE jsArray #-}
703+jsArray :: Name
704+jsArray = "JsArray"
705+
706+
707+{-# NOINLINE task #-}
708+task :: Name
709+task = "Task"
710+
711+
712+{-# NOINLINE router #-}
713+router :: Name
714+router = "Router"
715+
716+
717+{-# NOINLINE cmd #-}
718+cmd :: Name
719+cmd = "Cmd"
720+
721+
722+{-# NOINLINE sub #-}
723+sub :: Name
724+sub = "Sub"
725+
726+
727+{-# NOINLINE platform #-}
728+platform :: Name
729+platform = "Platform"
730+
731+
732+{-# NOINLINE virtualDom #-}
733+virtualDom :: Name
734+virtualDom = "VirtualDom"
735+
736+
737+{-# NOINLINE shader #-}
738+shader :: Name
739+shader = "Shader"
740+
741+
742+{-# NOINLINE debug #-}
743+debug :: Name
744+debug = "Debug"
745+
746+
747+{-# NOINLINE debugger #-}
748+debugger :: Name
749+debugger = "Debugger"
750+
751+
752+{-# NOINLINE bitwise #-}
753+bitwise :: Name
754+bitwise = "Bitwise"
755+
756+
757+{-# NOINLINE basics #-}
758+basics :: Name
759+basics = "Basics"
760+
761+
762+{-# NOINLINE utils #-}
763+utils :: Name
764+utils = "Utils"
765+
766+
767+{-# NOINLINE negate #-}
768+negate :: Name
769+negate = "negate"
770+
771+
772+{-# NOINLINE true #-}
773+true :: Name
774+true = "True"
775+
776+
777+{-# NOINLINE false #-}
778+false :: Name
779+false = "False"
780+
781+
782+{-# NOINLINE value #-}
783+value :: Name
784+value = "Value"
785+
786+
787+{-# NOINLINE node #-}
788+node :: Name
789+node = "Node"
790+
791+
792+{-# NOINLINE program #-}
793+program :: Name
794+program = "Program"
795+
796+
797+{-# NOINLINE main #-}
798+main :: Name
799+main = "main"
800+
801+
802+{-# NOINLINE dollar #-}
803+dollar :: Name
804+dollar = "$"
805+
806+
807+{-# NOINLINE identity #-}
808+identity :: Name
809+identity = "identity"
810+
811+
812+{-# NOINLINE replModule #-}
813+replModule :: Name
814+replModule = "Elm_Repl"