git.iko.soy/elk
on f4401ac help sign in
elk/compiler/src/Elm/Kernel.hs
365 lines 9.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE BangPatterns, EmptyDataDecls, OverloadedStrings, UnboxedTuples #-}
3module Elm.Kernel
4 ( Content(..)
5 , Chunk(..)
6 , fromByteString
7 , countFields
8 )
9 where
12import Control.Monad (liftM, liftM2)
13import Data.Binary (Binary, get, put, getWord8, putWord8)
14import qualified Data.ByteString.Internal as B
15import qualified Data.List as List
16import qualified Data.Map as Map
17import qualified Data.Name as Name
18import Data.Word (Word8, Word16)
19import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20import Foreign.ForeignPtr (ForeignPtr)
21import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
23import qualified AST.Source as Src
24import qualified Elm.ModuleName as ModuleName
25import qualified Elm.Package as Pkg
26import qualified Parse.Module as Module
27import qualified Parse.Space as Space
28import qualified Parse.Variable as Var
29import Parse.Primitives hiding (fromByteString)
30import qualified Parse.Primitives as P
31import qualified Reporting.Annotation as A
35-- CHUNK
38data Chunk
39 = JS B.ByteString
40 | ElmVar ModuleName.Canonical Name.Name
41 | JsVar Name.Name Name.Name
42 | ElmField Name.Name
43 | JsField Int
44 | JsEnum Int
45 | Debug
46 | Prod
50-- COUNT FIELDS
53countFields :: [Chunk] -> Map.Map Name.Name Int
54countFields chunks =
55 foldr addField Map.empty chunks
58addField :: Chunk -> Map.Map Name.Name Int -> Map.Map Name.Name Int
59addField chunk fields =
60 case chunk of
61 JS _ -> fields
62 ElmVar _ _ -> fields
63 JsVar _ _ -> fields
64 ElmField f -> Map.insertWith (+) f 1 fields
65 JsField _ -> fields
66 JsEnum _ -> fields
67 Debug -> fields
68 Prod -> fields
72-- FROM FILE
75data Content =
76 Content [Src.Import] [Chunk]
79type Foreigns =
80 Map.Map ModuleName.Raw Pkg.Name
83fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content
84fromByteString pkg foreigns bytes =
85 case P.fromByteString (parser pkg foreigns) toError bytes of
86 Right content ->
87 Just content
89 Left () ->
90 Nothing
93parser :: Pkg.Name -> Foreigns -> Parser () Content
94parser pkg foreigns =
95 do word2 0x2F 0x2A {-/*-} toError
96 Space.chomp ignoreError
97 Space.checkFreshLine toError
98 imports <- specialize ignoreError (Module.chompImports [])
99 word2 0x2A 0x2F {-*/-} toError
100 chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty
101 return (Content imports chunks)
104toError :: Row -> Col -> ()
105toError _ _ =
106 ()
109ignoreError :: a -> Row -> Col -> ()
110ignoreError _ _ _ =
111 ()
115-- PARSE CHUNKS
118parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]
119parseChunks vtable enums fields =
120 P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
121 let
122 (# chunks, newPos, newRow, newCol #) =
123 chompChunks vtable enums fields src pos end row col pos []
124 in
125 if newPos == end then
126 cok chunks (P.State src newPos end indent newRow newCol)
127 else
128 cerr row col toError
131chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
132chompChunks vs es fs src pos end row col lastPos revChunks =
133 if pos >= end then
134 let !js = toByteString src lastPos end in
135 (# reverse (JS js : revChunks), pos, row, col #)
137 else
138 let !word = unsafeIndex pos in
139 if word == 0x5F {-_-} then
140 let
141 !pos1 = plusPtr pos 1
142 !pos3 = plusPtr pos 3
143 in
144 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
145 let !js = toByteString src lastPos pos in
146 chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)
147 else
148 chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks
150 else if word == 0x0A {-\n-} then
151 chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
153 else
154 let
155 !newPos = plusPtr pos (getCharWidth word)
156 in
157 chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks
160toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString
161toByteString src pos end =
162 let
163 !off = minusPtr pos (unsafeForeignPtrToPtr src)
164 !len = minusPtr end pos
165 in
166 B.PS src off len
170-- relies on external checks in chompChunks
171chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
172chompTag vs es fs src pos end row col revChunks =
173 let
174 (# newPos, newCol #) = Var.chompInnerChars pos end col
175 !tagPos = plusPtr pos (-1)
176 !word = unsafeIndex tagPos
177 in
178 if word == 0x24 {-$-} then
179 let
180 !name = Name.fromPtr pos newPos
181 in
182 chompChunks vs es fs src newPos end row newCol newPos $
183 ElmField name : revChunks
184 else
185 let
186 !name = Name.fromPtr tagPos newPos
187 in
188 if 0x30 {-0-} <= word && word <= 0x39 {-9-} then
189 let
190 (enum, newEnums) =
191 lookupEnum (word - 0x30) name es
192 in
193 chompChunks vs newEnums fs src newPos end row newCol newPos $
194 JsEnum enum : revChunks
196 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
197 let
198 (field, newFields) =
199 lookupField name fs
200 in
201 chompChunks vs es newFields src newPos end row newCol newPos $
202 JsField field : revChunks
204 else if name == "DEBUG" then
205 chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks)
207 else if name == "PROD" then
208 chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks)
210 else
211 case Map.lookup name vs of
212 Just chunk ->
213 chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks)
215 Nothing ->
216 (# revChunks, pos, row, col #)
220-- FIELDS
223type Fields =
224 Map.Map Name.Name Int
227lookupField :: Name.Name -> Fields -> (Int, Fields)
228lookupField name fields =
229 case Map.lookup name fields of
230 Just n ->
231 ( n, fields )
233 Nothing ->
234 let n = Map.size fields in
235 ( n, Map.insert name n fields )
239-- ENUMS
242type Enums =
243 Map.Map Word8 (Map.Map Name.Name Int)
246lookupEnum :: Word8 -> Name.Name -> Enums -> (Int, Enums)
247lookupEnum word var allEnums =
248 let
249 enums =
250 Map.findWithDefault Map.empty word allEnums
251 in
252 case Map.lookup var enums of
253 Just n ->
254 ( n, allEnums )
256 Nothing ->
257 let n = Map.size enums in
258 ( n, Map.insert word (Map.insert var n enums) allEnums )
262-- PROCESS IMPORTS
265type VarTable =
266 Map.Map Name.Name Chunk
269toVarTable :: Pkg.Name -> Foreigns -> [Src.Import] -> VarTable
270toVarTable pkg foreigns imports =
271 List.foldl' (addImport pkg foreigns) Map.empty imports
274addImport :: Pkg.Name -> Foreigns -> VarTable -> Src.Import -> VarTable
275addImport pkg foreigns vtable (Src.Import (A.At _ importName) maybeAlias exposing) =
276 if Name.isKernel importName then
277 case maybeAlias of
278 Just _ ->
279 error ("cannot use `as` with kernel import of: " ++ Name.toChars importName)
281 Nothing ->
282 let
283 home = Name.getKernel importName
284 add table name =
285 Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table
286 in
287 List.foldl' add vtable (toNames exposing)
289 else
290 let
291 home = ModuleName.Canonical (Map.findWithDefault pkg importName foreigns) importName
292 prefix = toPrefix importName maybeAlias
293 add table name =
294 Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) table
295 in
296 List.foldl' add vtable (toNames exposing)
299toPrefix :: Name.Name -> Maybe Name.Name -> Name.Name
300toPrefix home maybeAlias =
301 case maybeAlias of
302 Just alias ->
303 alias
305 Nothing ->
306 if Name.hasDot home then
307 error ("kernel imports with dots need an alias: " ++ show (Name.toChars home))
308 else
309 home
312toNames :: Src.Exposing -> [Name.Name]
313toNames exposing =
314 case exposing of
315 Src.Open ->
316 error "cannot have `exposing (..)` in kernel code."
318 Src.Explicit exposedList ->
319 map toName exposedList
322toName :: A.Located Src.Exposed -> Name.Name
323toName (A.At _ exposed) =
324 case exposed of
325 Src.Lower name ->
326 name
328 Src.Upper name Src.Private ->
329 name
331 Src.Upper _ Src.Public ->
332 error "cannot have Maybe(..) syntax in kernel code header"
334 Src.Operator _ ->
335 error "cannot use binops in kernel code"
339-- BINARY
342instance Binary Chunk where
343 put chunk =
344 case chunk of
345 JS a -> putWord8 0 >> put a
346 ElmVar a b -> putWord8 1 >> put a >> put b
347 JsVar a b -> putWord8 2 >> put a >> put b
348 ElmField a -> putWord8 3 >> put a
349 JsField a -> putWord8 4 >> put a
350 JsEnum a -> putWord8 5 >> put a
351 Debug -> putWord8 6
352 Prod -> putWord8 7
354 get =
355 do word <- getWord8
356 case word of
357 0 -> liftM JS get
358 1 -> liftM2 ElmVar get get
359 2 -> liftM2 JsVar get get
360 3 -> liftM ElmField get
361 4 -> liftM JsField get
362 5 -> liftM JsEnum get
363 6 -> return Debug
364 7 -> return Prod
365 _ -> error "problem deserializing Elm.Kernel.Chunk"