git.iko.soy/elk
on 42f3721 help sign in
elk/compiler/src/Data/Name.hs
814 lines 16 kB history raw
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
3module 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
39import Control.Exception (assert)
40import Data.Binary (Binary(..), Get, getWord8, putWord8)
41import Data.Binary.Put (putBuilder)
42import Data.Binary.Get.Internal (readN)
43import qualified Data.ByteString.Internal as B
44import qualified Data.ByteString.Builder.Internal as B
45import qualified Data.List as List
46import Data.String (IsString(..))
47import qualified Data.Text as Text
48import qualified Data.Utf8 as Utf8
49import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
50import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
51import Foreign.Ptr (minusPtr, plusPtr)
52import 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 )
62import GHC.IO
63import GHC.ST (ST(ST), runST)
64import GHC.Prim
65import GHC.Word (Word8(W8#))
66import Prelude hiding (length, maybe, negate)
70-- UTF-8
73data Name =
74 Name ByteArray#
78-- LENGTH
81length :: Name -> Int
82length (Name ba#) =
83 I# (sizeofByteArray# ba#)
87-- EQUAL
90instance 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#)
102-- COMPARE
105-- TODO see if this can be written any faster
106instance 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
123-- STRING OVERLOADING
126instance 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 )
136writeChars :: MBA s -> Int -> [Char] -> ST s ()
137writeChars !mba !i chars =
138 case chars of
139 [] ->
140 return ()
142 c:cs ->
143 do writeChar8 mba i c
144 writeChars mba (i+1) cs
148-- BINARY
151instance Binary Name where
152 put name@(Name ba#) =
153 putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
154 >> putBuilder (toBuilder name)
155 get =
156 getWord8 >>= getName
159{-# INLINE getName #-}
160getName :: Word8 -> Get Name
161getName w =
162 let !n = fromIntegral w in
163 readN n (copyFromByteString n)
166{-# INLINE copyFromByteString #-}
167copyFromByteString :: Int -> B.ByteString -> Name
168copyFromByteString 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 )
179-- FROM BYTESTRING
182fromByteString :: ForeignPtr Word8 -> Int -> Int -> Name
183fromByteString 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 )
194-- TO UTF-8
197{-# INLINE toUtf8 #-}
198toUtf8 :: Name -> Utf8.Utf8
199toUtf8 (Name ba#) =
200 Utf8.Utf8 ba#
204-- TO BUILDER
207{-# INLINE toBuilder #-}
208toBuilder :: Name -> B.Builder
209toBuilder =
210 \name -> B.builder (toBuilderHelp name)
213{-# INLINE toBuilderHelp #-}
214toBuilderHelp :: Name -> B.BuildStep a -> B.BuildStep a
215toBuilderHelp !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)
234-- TO ESCAPED BUILDER
237{-# INLINE toEscapedBuilder #-}
238toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder
239toEscapedBuilder before after =
240 \name -> B.builder (toEscapedBuilderHelp before after name)
243{-# INLINE toEscapedBuilderHelp #-}
244toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
245toEscapedBuilderHelp 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)
266escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> ST RealWorld ()
267escape 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
276 else
277 return ()
281-- TO STRING
284toString :: Name -> String
285toString name =
286 Utf8.toString (toUtf8 name)
290-- HAS DOT
293hasDot :: Name -> Bool
294hasDot (Name ba#) =
295 let
296 !len# = sizeofByteArray# ba#
297 in
298 hasDotHelp ba# 0# len#
301hasDotHelp :: ByteArray# -> Int# -> Int# -> Bool
302hasDotHelp 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#
308 else
309 False
313-- TO TEXT
316toText :: Name -> Text.Text
317toText name =
318 Text.pack (toString name) -- TODO get rid of this?
322-- GET KERNEL
325getKernel :: Name -> Name
326getKernel 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 )
346-- STARTS WITH
349{-# INLINE startsWith #-}
350startsWith :: Name -> Name -> Bool
351startsWith (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#)
361isKernel :: Name -> Bool
362isKernel = startsWith prefix_kernel
364isNumberType :: Name -> Bool
365isNumberType = startsWith prefix_number
367isComparableType :: Name -> Bool
368isComparableType = startsWith prefix_comparable
370isAppendableType :: Name -> Bool
371isAppendableType = startsWith prefix_appendable
373isCompappendType :: Name -> Bool
374isCompappendType = startsWith prefix_compappend
376{-# NOINLINE prefix_kernel #-}
377prefix_kernel :: Name
378prefix_kernel = "Elm.Kernel."
380{-# NOINLINE prefix_number #-}
381prefix_number :: Name
382prefix_number = "number"
384{-# NOINLINE prefix_comparable #-}
385prefix_comparable :: Name
386prefix_comparable = "comparable"
388{-# NOINLINE prefix_appendable #-}
389prefix_appendable :: Name
390prefix_appendable = "appendable"
392{-# NOINLINE prefix_compappend #-}
393prefix_compappend :: Name
394prefix_compappend = "compappend"
398-- FROM INDEX
401fromVarIndex :: Int -> Name
402fromVarIndex 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 )
414{-# INLINE getIndexSize #-}
415getIndexSize :: Int -> Int
416getIndexSize n
417 | n < 10 = 3
418 | n < 100 = 4
419 | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)
423writeNumbers :: MBA s -> Int -> Int -> ST s ()
424writeNumbers !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
432fromTypeVariable :: Name -> Int -> Name
433fromTypeVariable 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 )
462fromTypeVariableScheme :: Int -> Name
463fromTypeVariableScheme 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 )
481-- FROM MANY NAMES
484fromManyNames :: [Name] -> Name
485fromManyNames 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 )
501writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
502writeNames mba# !offset# names s =
503 case names of
504 [] ->
505 s
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
521-- FROM WORDS
524fromWords :: [Word8] -> Name
525fromWords words =
526 runST
527 (
528 do mba <- newByteArray (List.length words)
529 writeWords mba 0 words
530 unsafeFreeze mba
531 )
534writeWords :: MBA s -> Int -> [Word8] -> ST s ()
535writeWords !mba !i words =
536 case words of
537 [] ->
538 return ()
540 w:ws ->
541 do writeWord8 mba i w
542 writeWords mba (i+1) ws
546-- SEP BY
549sepBy :: Word8 -> Name -> Name -> Name
550sepBy (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 )
572-- PRIMITIVES
575data MBA s =
576 MBA# (MutableByteArray# s)
579{-# INLINE newByteArray #-}
580newByteArray :: Int -> ST s (MBA s)
581newByteArray (I# len#) =
582 ST $ \s ->
583 case newByteArray# len# s of
584 (# s, mba# #) -> (# s, MBA# mba# #)
587{-# INLINE unsafeFreeze #-}
588unsafeFreeze :: MBA s -> ST s Name
589unsafeFreeze (MBA# mba#) =
590 ST $ \s ->
591 case unsafeFreezeByteArray# mba# s of
592 (# s, ba# #) -> (# s, Name ba# #)
595{-# INLINE writeChar8 #-}
596writeChar8 :: MBA s -> Int -> Char -> ST s ()
597writeChar8 (MBA# mba#) (I# offset#) (C# char#) =
598 ST $ \s ->
599 case writeCharArray# mba# offset# char# s of
600 s -> (# s, () #)
603{-# INLINE writeWord8 #-}
604writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
605writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
606 ST $ \s ->
607 case writeWord8Array# mba# offset# w# s of
608 s -> (# s, () #)
611{-# INLINE writeWordToPtr #-}
612writeWordToPtr :: Ptr a -> Int -> Word8 -> ST s ()
613writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
614 ST $ \s ->
615 case writeWord8OffAddr# addr# offset# word# s of
616 s -> (# s, () #)
619{-# INLINE copyFromPtr #-}
620copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
621copyFromPtr (Ptr addr#) (MBA# mba#) (I# offset#) (I# len#) =
622 ST $ \s ->
623 case copyAddrToByteArray# addr# mba# offset# len# s of
624 s -> (# s, () #)
627{-# INLINE copyToPtr #-}
628copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()
629copyToPtr (Name ba#) (I# offset#) (Ptr addr#) (I# len#) =
630 ST $ \s ->
631 case copyByteArrayToAddr# ba# offset# addr# len# s of
632 s -> (# s, () #)
635{-# INLINE copyToMBA #-}
636copyToMBA :: Name -> MBA s -> ST s ()
637copyToMBA (Name ba#) (MBA# mba#) =
638 ST $ \s ->
639 case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of
640 s -> (# s, () #)
644-- COMMON NAMES
647{-# NOINLINE int #-}
648int :: Name
649int = "Int"
652{-# NOINLINE float #-}
653float :: Name
654float = "Float"
657{-# NOINLINE bool #-}
658bool :: Name
659bool = "Bool"
662{-# NOINLINE char #-}
663char :: Name
664char = "Char"
667{-# NOINLINE string #-}
668string :: Name
669string = "String"
672{-# NOINLINE maybe #-}
673maybe :: Name
674maybe = "Maybe"
677{-# NOINLINE result #-}
678result :: Name
679result = "Result"
682{-# NOINLINE list #-}
683list :: Name
684list = "List"
687{-# NOINLINE array #-}
688array :: Name
689array = "Array"
692{-# NOINLINE dict #-}
693dict :: Name
694dict = "Dict"
697{-# NOINLINE tuple #-}
698tuple :: Name
699tuple = "Tuple"
702{-# NOINLINE jsArray #-}
703jsArray :: Name
704jsArray = "JsArray"
707{-# NOINLINE task #-}
708task :: Name
709task = "Task"
712{-# NOINLINE router #-}
713router :: Name
714router = "Router"
717{-# NOINLINE cmd #-}
718cmd :: Name
719cmd = "Cmd"
722{-# NOINLINE sub #-}
723sub :: Name
724sub = "Sub"
727{-# NOINLINE platform #-}
728platform :: Name
729platform = "Platform"
732{-# NOINLINE virtualDom #-}
733virtualDom :: Name
734virtualDom = "VirtualDom"
737{-# NOINLINE shader #-}
738shader :: Name
739shader = "Shader"
742{-# NOINLINE debug #-}
743debug :: Name
744debug = "Debug"
747{-# NOINLINE debugger #-}
748debugger :: Name
749debugger = "Debugger"
752{-# NOINLINE bitwise #-}
753bitwise :: Name
754bitwise = "Bitwise"
757{-# NOINLINE basics #-}
758basics :: Name
759basics = "Basics"
762{-# NOINLINE utils #-}
763utils :: Name
764utils = "Utils"
767{-# NOINLINE negate #-}
768negate :: Name
769negate = "negate"
772{-# NOINLINE true #-}
773true :: Name
774true = "True"
777{-# NOINLINE false #-}
778false :: Name
779false = "False"
782{-# NOINLINE value #-}
783value :: Name
784value = "Value"
787{-# NOINLINE node #-}
788node :: Name
789node = "Node"
792{-# NOINLINE program #-}
793program :: Name
794program = "Program"
797{-# NOINLINE main #-}
798main :: Name
799main = "main"
802{-# NOINLINE dollar #-}
803dollar :: Name
804dollar = "$"
807{-# NOINLINE identity #-}
808identity :: Name
809identity = "identity"
812{-# NOINLINE replModule #-}
813replModule :: Name
814replModule = "Elm_Repl"