git.iko.soy/elk
on 2edbe13 help sign in
elk/compiler/src/Elm/String.hs
133 lines 3.0 kB history raw
1{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}
3module Elm.String
4 ( String
5 , toChars
6 , toBuilder
7 , Chunk(..)
8 , fromChunks
9 )
10 where
13import Prelude hiding (String)
14import Data.Binary (Binary, get, put)
15import Data.Bits ((.&.), shiftR)
16import qualified Data.ByteString.Builder as B
17import qualified Data.Utf8 as Utf8
18import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
19import GHC.Exts (RealWorld, Ptr)
20import GHC.IO (stToIO, unsafeDupablePerformIO)
21import GHC.ST (ST)
22import GHC.Word (Word8)
26-- STRINGS
29type String =
30 Utf8.Utf8 ELM_STRING
33data ELM_STRING
37-- HELPERS
40toChars :: String -> [Char]
41toChars =
42 Utf8.toChars
45{-# INLINE toBuilder #-}
46toBuilder :: String -> B.Builder
47toBuilder =
48 Utf8.toBuilder
52-- FROM CHUNKS
55data Chunk
56 = Slice (Ptr Word8) Int
57 | Escape Word8
58 | CodePoint Int
61fromChunks :: [Chunk] -> String
62fromChunks chunks =
63 unsafeDupablePerformIO (stToIO (
64 do let !len = sum (map chunkToWidth chunks)
65 mba <- newByteArray len
66 writeChunks mba 0 chunks
67 freeze mba
68 ))
71chunkToWidth :: Chunk -> Int
72chunkToWidth chunk =
73 case chunk of
74 Slice _ len -> len
75 Escape _ -> 2
76 CodePoint c -> if c < 0xFFFF then 6 else 12
79writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
80writeChunks mba offset chunks =
81 case chunks of
82 [] ->
83 return ()
85 chunk : chunks ->
86 case chunk of
87 Slice ptr len ->
88 do copyFromPtr ptr mba offset len
89 let !newOffset = offset + len
90 writeChunks mba newOffset chunks
92 Escape word ->
93 do writeWord8 mba offset 0x5C {- \ -}
94 writeWord8 mba (offset + 1) word
95 let !newOffset = offset + 2
96 writeChunks mba newOffset chunks
98 CodePoint code ->
99 if code < 0xFFFF then
100 do writeCode mba offset code
101 let !newOffset = offset + 6
102 writeChunks mba newOffset chunks
103 else
104 do let (hi,lo) = divMod (code - 0x10000) 0x400
105 writeCode mba (offset ) (hi + 0xD800)
106 writeCode mba (offset + 6) (lo + 0xDC00)
107 let !newOffset = offset + 12
108 writeChunks mba newOffset chunks
111writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
112writeCode mba offset code =
113 do writeWord8 mba offset 0x5C {- \ -}
114 writeWord8 mba (offset + 1) 0x75 {- u -}
115 writeHex mba (offset + 2) (shiftR code 12)
116 writeHex mba (offset + 3) (shiftR code 8)
117 writeHex mba (offset + 4) (shiftR code 4)
118 writeHex mba (offset + 5) code
121writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
122writeHex mba !offset !bits =
123 do let !n = fromIntegral bits .&. 0x0F
124 writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
128-- BINARY
131instance Binary (Utf8.Utf8 ELM_STRING) where
132 get = Utf8.getVeryLong
133 put = Utf8.putVeryLong