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