1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
3module Data.Name
4  ( Name
5  --
6  , toChars
7  , toElmString
8  , toBuilder
9  --
10  , fromPtr
11  , fromChars
12  --
13  , getKernel
14  , hasDot
15  , splitDots
16  , isKernel
17  , isNumberType
18  , isComparableType
19  , isAppendableType
20  , isCompappendType
21  , fromVarIndex
22  , fromWords
23  , fromManyNames
24  , fromTypeVariable
25  , fromTypeVariableScheme
26  , sepBy
27  --
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, _Main, dollar, identity
34  , replModule, replValueToPrint
35  )
36  where
37
38
39import Prelude hiding (length, maybe, negate)
40import Control.Exception (assert)
41import qualified Data.Binary as Binary
42import qualified Data.ByteString.Builder.Internal as B
43import qualified Data.Coerce as Coerce
44import qualified Data.List as List
45import qualified Data.String as Chars
46import qualified Data.Utf8 as Utf8
47import GHC.Exts
48  ( Int(I#), Ptr
49  , MutableByteArray#
50  , isTrue#
51  , newByteArray#
52  , sizeofByteArray#
53  , unsafeFreezeByteArray#
54  )
55import GHC.ST (ST(ST), runST)
56import GHC.Prim
57import GHC.Word (Word8(W8#))
58
59import qualified Elm.String as ES
60
61
62
63-- NAME
64
65
66type Name =
67  Utf8.Utf8 ELM_NAME
68
69
70data ELM_NAME
71
72
73
74-- INSTANCES
75
76
77instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
78  fromString = Utf8.fromChars
79
80instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
81  get = Utf8.getUnder256
82  put = Utf8.putUnder256
83
84
85
86-- TO
87
88
89toChars :: Name -> [Char]
90toChars =
91  Utf8.toChars
92
93
94toElmString :: Name -> ES.String
95toElmString =
96  Coerce.coerce
97
98
99{-# INLINE toBuilder #-}
100toBuilder :: Name -> B.Builder
101toBuilder =
102  Utf8.toBuilder
103
104
105
106-- FROM
107
108
109fromPtr :: Ptr Word8 -> Ptr Word8 -> Name
110fromPtr =
111  Utf8.fromPtr
112
113
114fromChars :: [Char] -> Name
115fromChars =
116  Utf8.fromChars
117
118
119
120-- HAS DOT
121
122
123hasDot :: Name -> Bool
124hasDot name =
125  Utf8.contains 0x2E {- . -} name
126
127
128splitDots :: Name -> [Name]
129splitDots name =
130  Utf8.split 0x2E {- . -} name
131
132
133
134-- GET KERNEL
135
136
137getKernel :: Name -> Name
138getKernel name@(Utf8.Utf8 ba#) =
139  assert (isKernel name)
140  (
141    runST
142    (
143      let
144        !size# = sizeofByteArray# ba# -# 11#
145      in
146      ST $ \s ->
147        case newByteArray# size# s of
148          (# s, mba# #) ->
149            case copyByteArray# ba# 11# mba# 0# size# s of
150              s ->
151                case unsafeFreezeByteArray# mba# s of
152                  (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
153    )
154  )
155
156
157
158-- STARTS WITH
159
160
161isKernel :: Name -> Bool
162isKernel = Utf8.startsWith prefix_kernel
163
164isNumberType :: Name -> Bool
165isNumberType = Utf8.startsWith prefix_number
166
167isComparableType :: Name -> Bool
168isComparableType = Utf8.startsWith prefix_comparable
169
170isAppendableType :: Name -> Bool
171isAppendableType = Utf8.startsWith prefix_appendable
172
173isCompappendType :: Name -> Bool
174isCompappendType = Utf8.startsWith prefix_compappend
175
176{-# NOINLINE prefix_kernel #-}
177prefix_kernel :: Name
178prefix_kernel = fromChars "Elm.Kernel."
179
180{-# NOINLINE prefix_number #-}
181prefix_number :: Name
182prefix_number = fromChars "number"
183
184{-# NOINLINE prefix_comparable #-}
185prefix_comparable :: Name
186prefix_comparable = fromChars "comparable"
187
188{-# NOINLINE prefix_appendable #-}
189prefix_appendable :: Name
190prefix_appendable = fromChars "appendable"
191
192{-# NOINLINE prefix_compappend #-}
193prefix_compappend :: Name
194prefix_compappend = fromChars "compappend"
195
196
197
198-- FROM VAR INDEX
199
200
201fromVarIndex :: Int -> Name
202fromVarIndex n =
203  runST
204  (
205    do  let !size = 2 + getIndexSize n
206        mba <- newByteArray size
207        writeWord8 mba 0 0x5F {- _ -}
208        writeWord8 mba 1 0x76 {- v -}
209        writeDigitsAtEnd mba size n
210        freeze mba
211  )
212
213
214{-# INLINE getIndexSize #-}
215getIndexSize :: Int -> Int
216getIndexSize n
217  | n < 10  = 1
218  | n < 100 = 2
219  | True    = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
220
221
222
223writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()
224writeDigitsAtEnd !mba !oldOffset !n =
225  do  let (q,r) = quotRem n 10
226      let !newOffset = oldOffset - 1
227      writeWord8 mba newOffset (0x30 + fromIntegral r)
228      if q <= 0
229        then return ()
230        else writeDigitsAtEnd mba newOffset q
231
232
233
234-- FROM TYPE VARIABLE
235
236
237fromTypeVariable :: Name -> Int -> Name
238fromTypeVariable name@(Utf8.Utf8 ba#) index =
239  if index <= 0 then
240    name
241  else
242    let
243      len# = sizeofByteArray# ba#
244      end# = indexWord8Array# ba# (len# -# 1#)
245    in
246    if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then
247      runST
248      (
249        do  let !size = I# len# + 1 + getIndexSize index
250            mba <- newByteArray size
251            copyToMBA name mba
252            writeWord8 mba (I# len#) 0x5F {- _ -}
253            writeDigitsAtEnd mba size index
254            freeze mba
255      )
256    else
257      runST
258      (
259        do  let !size = I# len# + getIndexSize index
260            mba <- newByteArray size
261            copyToMBA name mba
262            writeDigitsAtEnd mba size index
263            freeze mba
264      )
265
266
267
268-- FROM TYPE VARIABLE SCHEME
269
270
271fromTypeVariableScheme :: Int -> Name
272fromTypeVariableScheme scheme =
273  runST
274  (
275    if scheme < 26 then
276      do  mba <- newByteArray 1
277          writeWord8 mba 0 (0x61 + fromIntegral scheme)
278          freeze mba
279    else
280      do  let (extra, letter) = quotRem scheme 26
281          let !size = 1 + getIndexSize extra
282          mba <- newByteArray size
283          writeWord8 mba 0 (0x61 + fromIntegral letter)
284          writeDigitsAtEnd mba size extra
285          freeze mba
286  )
287
288
289
290-- FROM MANY NAMES
291--
292-- Creating a unique name by combining all the subnames can create names
293-- longer than 256 bytes relatively easily. So instead, the first given name
294-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)
295--
296-- This should be a unique name since 0.19 disallows shadowing. It would not
297-- be possible for multiple top-level cycles to include values with the same
298-- name, so the important thing is to make the cycle name distinct from the
299-- normal name. Same logic for destructuring patterns like (x,y)
300
301
302fromManyNames :: [Name] -> Name
303fromManyNames names =
304  case names of
305    [] ->
306      blank
307      -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)
308      -- but maybe unused patterns should be stripped out instead
309
310    Utf8.Utf8 ba# : _ ->
311      let
312        len# = sizeofByteArray# ba#
313      in
314      runST
315      (
316        ST $ \s ->
317          case newByteArray# (len# +# 3#) s of
318            (# s, mba# #) ->
319              case writeWord8Array# mba# 0# 0x5F## {-_-} s of
320                s ->
321                  case writeWord8Array# mba# 1# 0x4D## {-M-} s of
322                    s ->
323                      case writeWord8Array# mba# 2# 0x24## {-$-} s of
324                        s ->
325                          case copyByteArray# ba# 0# mba# 3# len# s of
326                            s ->
327                              case unsafeFreezeByteArray# mba# s of
328                                (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
329      )
330
331
332{-# NOINLINE blank #-}
333blank :: Name
334blank =
335  fromWords [0x5F,0x4D,0x24] {-_M$-}
336
337
338
339-- FROM WORDS
340
341
342fromWords :: [Word8] -> Name
343fromWords words =
344  runST
345  (
346    do  mba <- newByteArray (List.length words)
347        writeWords mba 0 words
348        freeze mba
349  )
350
351
352writeWords :: MBA s -> Int -> [Word8] -> ST s ()
353writeWords !mba !i words =
354  case words of
355    [] ->
356      return ()
357
358    w:ws ->
359      do  writeWord8 mba i w
360          writeWords mba (i+1) ws
361
362
363
364-- SEP BY
365
366
367sepBy :: Word8 -> Name -> Name -> Name
368sepBy (W8# sep#) (Utf8.Utf8 ba1#) (Utf8.Utf8 ba2#) =
369  let
370    !len1# = sizeofByteArray# ba1#
371    !len2# = sizeofByteArray# ba2#
372  in
373  runST
374  (
375    ST $ \s ->
376      case newByteArray# (len1# +# len2# +# 1#) s of
377        (# s, mba# #) ->
378          case copyByteArray# ba1# 0# mba# 0# len1# s of
379            s ->
380              case writeWord8Array# mba# len1# sep# s of
381                s ->
382                  case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of
383                    s ->
384                      case unsafeFreezeByteArray# mba# s of
385                        (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
386  )
387
388
389
390-- PRIMITIVES
391
392
393data MBA s =
394  MBA# (MutableByteArray# s)
395
396
397{-# INLINE newByteArray #-}
398newByteArray :: Int -> ST s (MBA s)
399newByteArray (I# len#) =
400  ST $ \s ->
401    case newByteArray# len# s of
402      (# s, mba# #) -> (# s, MBA# mba# #)
403
404
405{-# INLINE freeze #-}
406freeze :: MBA s -> ST s Name
407freeze (MBA# mba#) =
408  ST $ \s ->
409    case unsafeFreezeByteArray# mba# s of
410      (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
411
412
413{-# INLINE writeWord8 #-}
414writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
415writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
416  ST $ \s ->
417    case writeWord8Array# mba# offset# w# s of
418      s -> (# s, () #)
419
420
421{-# INLINE copyToMBA #-}
422copyToMBA :: Name -> MBA s -> ST s ()
423copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
424    ST $ \s ->
425      case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of
426        s -> (# s, () #)
427
428
429
430-- COMMON NAMES
431
432
433{-# NOINLINE int #-}
434int :: Name
435int = fromChars "Int"
436
437
438{-# NOINLINE float #-}
439float :: Name
440float = fromChars "Float"
441
442
443{-# NOINLINE bool #-}
444bool :: Name
445bool = fromChars "Bool"
446
447
448{-# NOINLINE char #-}
449char :: Name
450char = fromChars "Char"
451
452
453{-# NOINLINE string #-}
454string :: Name
455string = fromChars "String"
456
457
458{-# NOINLINE maybe #-}
459maybe :: Name
460maybe = fromChars "Maybe"
461
462
463{-# NOINLINE result #-}
464result :: Name
465result = fromChars "Result"
466
467
468{-# NOINLINE list #-}
469list :: Name
470list = fromChars "List"
471
472
473{-# NOINLINE array #-}
474array :: Name
475array = fromChars "Array"
476
477
478{-# NOINLINE dict #-}
479dict :: Name
480dict = fromChars "Dict"
481
482
483{-# NOINLINE tuple #-}
484tuple :: Name
485tuple = fromChars "Tuple"
486
487
488{-# NOINLINE jsArray #-}
489jsArray :: Name
490jsArray = fromChars "JsArray"
491
492
493{-# NOINLINE task #-}
494task :: Name
495task = fromChars "Task"
496
497
498{-# NOINLINE router #-}
499router :: Name
500router = fromChars "Router"
501
502
503{-# NOINLINE cmd #-}
504cmd :: Name
505cmd = fromChars "Cmd"
506
507
508{-# NOINLINE sub #-}
509sub :: Name
510sub = fromChars "Sub"
511
512
513{-# NOINLINE platform #-}
514platform :: Name
515platform = fromChars "Platform"
516
517
518{-# NOINLINE virtualDom #-}
519virtualDom :: Name
520virtualDom = fromChars "VirtualDom"
521
522
523{-# NOINLINE shader #-}
524shader :: Name
525shader = fromChars "Shader"
526
527
528{-# NOINLINE debug #-}
529debug :: Name
530debug = fromChars "Debug"
531
532
533{-# NOINLINE debugger #-}
534debugger :: Name
535debugger = fromChars "Debugger"
536
537
538{-# NOINLINE bitwise #-}
539bitwise :: Name
540bitwise = fromChars "Bitwise"
541
542
543{-# NOINLINE basics #-}
544basics :: Name
545basics = fromChars "Basics"
546
547
548{-# NOINLINE utils #-}
549utils :: Name
550utils = fromChars "Utils"
551
552
553{-# NOINLINE negate #-}
554negate :: Name
555negate = fromChars "negate"
556
557
558{-# NOINLINE true #-}
559true :: Name
560true = fromChars "True"
561
562
563{-# NOINLINE false #-}
564false :: Name
565false = fromChars "False"
566
567
568{-# NOINLINE value #-}
569value :: Name
570value = fromChars "Value"
571
572
573{-# NOINLINE node #-}
574node :: Name
575node = fromChars "Node"
576
577
578{-# NOINLINE program #-}
579program :: Name
580program = fromChars "Program"
581
582
583{-# NOINLINE _main #-}
584_main :: Name
585_main = fromChars "main"
586
587
588{-# NOINLINE _Main #-}
589_Main :: Name
590_Main = fromChars "Main"
591
592
593{-# NOINLINE dollar #-}
594dollar :: Name
595dollar = fromChars "$"
596
597
598{-# NOINLINE identity #-}
599identity :: Name
600identity = fromChars "identity"
601
602
603{-# NOINLINE replModule #-}
604replModule :: Name
605replModule = fromChars "Elm_Repl"
606
607
608{-# NOINLINE replValueToPrint #-}
609replValueToPrint :: Name
610replValueToPrint = fromChars "repl_input_value_"
611