git.iko.soy/elk
on f4401ac help sign in
elk/compiler/src/Data/Name.hs
600 lines 11 kB history raw
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
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#))
59import qualified Elm.String as ES
63-- NAME
66type Name =
67 Utf8.Utf8 ELM_NAME
70data ELM_NAME
74-- INSTANCES
77instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
78 fromString = Utf8.fromChars
80instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
81 get = Utf8.getUnder256
82 put = Utf8.putUnder256
86-- TO
89toChars :: Name -> [Char]
90toChars =
91 Utf8.toChars
94toElmString :: Name -> ES.String
95toElmString =
96 Coerce.coerce
99{-# INLINE toBuilder #-}
100toBuilder :: Name -> B.Builder
101toBuilder =
102 Utf8.toBuilder
106-- FROM
109fromPtr :: Ptr Word8 -> Ptr Word8 -> Name
110fromPtr =
111 Utf8.fromPtr
114fromChars :: [Char] -> Name
115fromChars =
116 Utf8.fromChars
120-- HAS DOT
123hasDot :: Name -> Bool
124hasDot name =
125 Utf8.contains 0x2E {- . -} name
128splitDots :: Name -> [Name]
129splitDots name =
130 Utf8.split 0x2E {- . -} name
134-- GET KERNEL
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 )
158-- STARTS WITH
161isKernel :: Name -> Bool
162isKernel = Utf8.startsWith prefix_kernel
164isNumberType :: Name -> Bool
165isNumberType = Utf8.startsWith prefix_number
167isComparableType :: Name -> Bool
168isComparableType = Utf8.startsWith prefix_comparable
170isAppendableType :: Name -> Bool
171isAppendableType = Utf8.startsWith prefix_appendable
173isCompappendType :: Name -> Bool
174isCompappendType = Utf8.startsWith prefix_compappend
176{-# NOINLINE prefix_kernel #-}
177prefix_kernel :: Name
178prefix_kernel = fromChars "Elm.Kernel."
180{-# NOINLINE prefix_number #-}
181prefix_number :: Name
182prefix_number = fromChars "number"
184{-# NOINLINE prefix_comparable #-}
185prefix_comparable :: Name
186prefix_comparable = fromChars "comparable"
188{-# NOINLINE prefix_appendable #-}
189prefix_appendable :: Name
190prefix_appendable = fromChars "appendable"
192{-# NOINLINE prefix_compappend #-}
193prefix_compappend :: Name
194prefix_compappend = fromChars "compappend"
198-- FROM VAR INDEX
201fromVarIndex :: Int -> Name
202fromVarIndex n =
203 runST
204 (
205 do let !size = getIndexSize n
206 mba <- newByteArray size
207 writeWord8 mba 0 0x5F {- _ -}
208 writeWord8 mba 1 0x76 {- v -}
209 writeDigits mba (size - 1) n
210 freeze mba
211 )
214{-# INLINE getIndexSize #-}
215getIndexSize :: Int -> Int
216getIndexSize n
217 | n < 10 = 3
218 | n < 100 = 4
219 | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)
223writeDigits :: MBA s -> Int -> Int -> ST s ()
224writeDigits !mba !offset !n =
225 do let (q,r) = quotRem n 10
226 writeWord8 mba offset (0x30 + fromIntegral r)
227 if q <= 0
228 then return ()
229 else writeDigits mba (offset-1) q
233-- FROM TYPE VARIABLE
236fromTypeVariable :: Name -> Int -> Name
237fromTypeVariable name@(Utf8.Utf8 ba#) index =
238 if index <= 0 then
239 name
240 else
241 let
242 len# = sizeofByteArray# ba#
243 end# = indexWord8Array# ba# (len# -# 1#)
244 in
245 if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then
246 runST
247 (
248 do let !size = I# len# + 1 + getIndexSize index
249 mba <- newByteArray size
250 copyToMBA name mba
251 writeWord8 mba (I# len#) 0x5F {- _ -}
252 writeDigits mba (size - 1) index
253 freeze mba
254 )
255 else
256 runST
257 (
258 do let !size = I# len# + getIndexSize index
259 mba <- newByteArray size
260 copyToMBA name mba
261 writeDigits mba (size - 1) index
262 freeze mba
263 )
267-- FROM TYPE VARIABLE SCHEME
270fromTypeVariableScheme :: Int -> Name
271fromTypeVariableScheme scheme =
272 runST
273 (
274 if scheme < 26 then
275 do mba <- newByteArray 1
276 writeWord8 mba 0 (0x61 + fromIntegral scheme)
277 freeze mba
278 else
279 do let (extra, letter) = quotRem scheme 26
280 let !size = getIndexSize extra
281 mba <- newByteArray size
282 writeWord8 mba 0 (0x61 + fromIntegral letter)
283 writeDigits mba (size - 1) extra
284 freeze mba
285 )
289-- FROM MANY NAMES
292fromManyNames :: [Name] -> Name
293fromManyNames names =
294 let
295 !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
296 in
297 runST
298 (
299 ST $ \s ->
300 case newByteArray# size# s of
301 (# s, mba# #) ->
302 case writeNames mba# 0# names s of
303 s ->
304 case unsafeFreezeByteArray# mba# s of
305 (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
306 )
309writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
310writeNames mba# !offset# names s =
311 case names of
312 [] ->
313 s
315 (Utf8.Utf8 ba#) : names ->
316 case writeWord8Array# mba# offset# 0x24## {- $ -} s of
317 s ->
318 let
319 !offset1# = offset# +# 1#
320 !len# = sizeofByteArray# ba#
321 !newOffset# = offset1# +# len#
322 in
323 case copyByteArray# ba# 0# mba# offset1# len# s of
324 s ->
325 writeNames mba# newOffset# names s
329-- FROM WORDS
332fromWords :: [Word8] -> Name
333fromWords words =
334 runST
335 (
336 do mba <- newByteArray (List.length words)
337 writeWords mba 0 words
338 freeze mba
339 )
342writeWords :: MBA s -> Int -> [Word8] -> ST s ()
343writeWords !mba !i words =
344 case words of
345 [] ->
346 return ()
348 w:ws ->
349 do writeWord8 mba i w
350 writeWords mba (i+1) ws
354-- SEP BY
357sepBy :: Word8 -> Name -> Name -> Name
358sepBy (W8# sep#) (Utf8.Utf8 ba1#) (Utf8.Utf8 ba2#) =
359 let
360 !len1# = sizeofByteArray# ba1#
361 !len2# = sizeofByteArray# ba2#
362 in
363 runST
364 (
365 ST $ \s ->
366 case newByteArray# (len1# +# len2# +# 1#) s of
367 (# s, mba# #) ->
368 case copyByteArray# ba1# 0# mba# 0# len1# s of
369 s ->
370 case writeWord8Array# mba# len1# sep# s of
371 s ->
372 case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of
373 s ->
374 case unsafeFreezeByteArray# mba# s of
375 (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
376 )
380-- PRIMITIVES
383data MBA s =
384 MBA# (MutableByteArray# s)
387{-# INLINE newByteArray #-}
388newByteArray :: Int -> ST s (MBA s)
389newByteArray (I# len#) =
390 ST $ \s ->
391 case newByteArray# len# s of
392 (# s, mba# #) -> (# s, MBA# mba# #)
395{-# INLINE freeze #-}
396freeze :: MBA s -> ST s Name
397freeze (MBA# mba#) =
398 ST $ \s ->
399 case unsafeFreezeByteArray# mba# s of
400 (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
403{-# INLINE writeWord8 #-}
404writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
405writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
406 ST $ \s ->
407 case writeWord8Array# mba# offset# w# s of
408 s -> (# s, () #)
411{-# INLINE copyToMBA #-}
412copyToMBA :: Name -> MBA s -> ST s ()
413copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
414 ST $ \s ->
415 case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of
416 s -> (# s, () #)
420-- COMMON NAMES
423{-# NOINLINE int #-}
424int :: Name
425int = fromChars "Int"
428{-# NOINLINE float #-}
429float :: Name
430float = fromChars "Float"
433{-# NOINLINE bool #-}
434bool :: Name
435bool = fromChars "Bool"
438{-# NOINLINE char #-}
439char :: Name
440char = fromChars "Char"
443{-# NOINLINE string #-}
444string :: Name
445string = fromChars "String"
448{-# NOINLINE maybe #-}
449maybe :: Name
450maybe = fromChars "Maybe"
453{-# NOINLINE result #-}
454result :: Name
455result = fromChars "Result"
458{-# NOINLINE list #-}
459list :: Name
460list = fromChars "List"
463{-# NOINLINE array #-}
464array :: Name
465array = fromChars "Array"
468{-# NOINLINE dict #-}
469dict :: Name
470dict = fromChars "Dict"
473{-# NOINLINE tuple #-}
474tuple :: Name
475tuple = fromChars "Tuple"
478{-# NOINLINE jsArray #-}
479jsArray :: Name
480jsArray = fromChars "JsArray"
483{-# NOINLINE task #-}
484task :: Name
485task = fromChars "Task"
488{-# NOINLINE router #-}
489router :: Name
490router = fromChars "Router"
493{-# NOINLINE cmd #-}
494cmd :: Name
495cmd = fromChars "Cmd"
498{-# NOINLINE sub #-}
499sub :: Name
500sub = fromChars "Sub"
503{-# NOINLINE platform #-}
504platform :: Name
505platform = fromChars "Platform"
508{-# NOINLINE virtualDom #-}
509virtualDom :: Name
510virtualDom = fromChars "VirtualDom"
513{-# NOINLINE shader #-}
514shader :: Name
515shader = fromChars "Shader"
518{-# NOINLINE debug #-}
519debug :: Name
520debug = fromChars "Debug"
523{-# NOINLINE debugger #-}
524debugger :: Name
525debugger = fromChars "Debugger"
528{-# NOINLINE bitwise #-}
529bitwise :: Name
530bitwise = fromChars "Bitwise"
533{-# NOINLINE basics #-}
534basics :: Name
535basics = fromChars "Basics"
538{-# NOINLINE utils #-}
539utils :: Name
540utils = fromChars "Utils"
543{-# NOINLINE negate #-}
544negate :: Name
545negate = fromChars "negate"
548{-# NOINLINE true #-}
549true :: Name
550true = fromChars "True"
553{-# NOINLINE false #-}
554false :: Name
555false = fromChars "False"
558{-# NOINLINE value #-}
559value :: Name
560value = fromChars "Value"
563{-# NOINLINE node #-}
564node :: Name
565node = fromChars "Node"
568{-# NOINLINE program #-}
569program :: Name
570program = fromChars "Program"
573{-# NOINLINE _main #-}
574_main :: Name
575_main = fromChars "main"
578{-# NOINLINE _Main #-}
579_Main :: Name
580_Main = fromChars "Main"
583{-# NOINLINE dollar #-}
584dollar :: Name
585dollar = fromChars "$"
588{-# NOINLINE identity #-}
589identity :: Name
590identity = fromChars "identity"
593{-# NOINLINE replModule #-}
594replModule :: Name
595replModule = fromChars "Elm_Repl"
598{-# NOINLINE replValueToPrint #-}
599replValueToPrint :: Name
600replValueToPrint = fromChars "repl_input_value_"