git.iko.soy/elk
on master help sign in
Move kernel parsing code to Elm.Kernel
962f413Evan Czaplicki
compiler/src/AST/Optimized.hs+10−68
compare with master
unifiedsplit
@@ -3,7 +3,6 @@ module AST.Optimized
3 ( Def(..)
3 ( Def(..)
4 , Expr(..)
4 , Expr(..)
5 , Global(..)
5 , Global(..)
6− , kernel
7 , Path(..)
6 , Path(..)
8 , Destructor(..)
7 , Destructor(..)
9 , Decider(..)
8 , Decider(..)
@@ -12,28 +11,24 @@ module AST.Optimized
12 , Main(..)
11 , Main(..)
13 , Node(..)
12 , Node(..)
14 , EffectsType(..)
13 , EffectsType(..)
15− , KContent(..)
16− , KChunk(..)
17 )
14 )
18 where
15 where
19
16
20
17
21import Control.Monad (liftM, liftM2, liftM3, liftM4)
18import Control.Monad (liftM, liftM2, liftM3, liftM4)
22import Data.Binary
19import Data.Binary
23−import qualified Data.ByteString as BS
24import qualified Data.Map as Map
20import qualified Data.Map as Map
25−import qualified Data.Name as Name
26import Data.Name (Name)
21import Data.Name (Name)
27import qualified Data.Set as Set
22import qualified Data.Set as Set
28−import Data.Text (Text)
29−import Data.Utf8 (Utf8)
23+import qualified Data.Utf8 as Utf8
30
24
31import qualified AST.Canonical as Can
25import qualified AST.Canonical as Can
26+import qualified AST.Utils.Shader as Shader
32import qualified Data.Index as Index
27import qualified Data.Index as Index
28+import qualified Elm.Kernel as K
33import qualified Elm.ModuleName as ModuleName
29import qualified Elm.ModuleName as ModuleName
34−import qualified Elm.Package as Pkg
35import qualified Optimize.DecisionTree as DT
30import qualified Optimize.DecisionTree as DT
36−import qualified Reporting.Region as R
31+import qualified Reporting.Annotation as A
37
32
38
33
39
34
@@ -42,16 +37,16 @@ import qualified Reporting.Region as R
42
37
43data Expr
38data Expr
44 = Bool Bool
39 = Bool Bool
45− | Chr Utf8
40+ | Chr Utf8.String
46− | Str Utf8
41+ | Str Utf8.String
47 | Int Int
42 | Int Int
48− | Float Double
43+ | Float (Utf8.Under256 Float)
49 | VarLocal Name
44 | VarLocal Name
50 | VarGlobal Global
45 | VarGlobal Global
51 | VarEnum Global Index.ZeroBased
46 | VarEnum Global Index.ZeroBased
52 | VarBox Global
47 | VarBox Global
53 | VarCycle ModuleName.Canonical Name
48 | VarCycle ModuleName.Canonical Name
54− | VarDebug Name ModuleName.Canonical R.Region (Maybe Name)
49+ | VarDebug Name ModuleName.Canonical A.Region (Maybe Name)
55 | VarKernel Name Name
50 | VarKernel Name Name
56 | List [Expr]
51 | List [Expr]
57 | Function [Name] Expr
52 | Function [Name] Expr
@@ -67,20 +62,13 @@ data Expr
67 | Record (Map.Map Name Expr)
62 | Record (Map.Map Name Expr)
68 | Unit
63 | Unit
69 | Tuple Expr Expr (Maybe Expr)
64 | Tuple Expr Expr (Maybe Expr)
70− | Shader Text (Set.Set Name) (Set.Set Name)
65+ | Shader Shader.Source (Set.Set Name) (Set.Set Name)
71
66
72
67
73data Global = Global ModuleName.Canonical Name
68data Global = Global ModuleName.Canonical Name
74 deriving (Eq, Ord)
69 deriving (Eq, Ord)
75
70
76
71
77−-- Provide "List" not "Elm.Kernel.List"
78−--
79−kernel :: Name -> Global
80−kernel home =
81− Global (ModuleName.Canonical Pkg.kernel home) Name.dollar
82−
83−
84
72
85-- DEFINITIONS
73-- DEFINITIONS
86
74
@@ -154,7 +142,7 @@ data Node
154 | Link Global
142 | Link Global
155 | Cycle [Name] [(Name, Expr)] [Def] (Set.Set Global)
143 | Cycle [Name] [(Name, Expr)] [Def] (Set.Set Global)
156 | Manager EffectsType
144 | Manager EffectsType
157− | Kernel KContent (Maybe KContent)
145+ | Kernel [K.Chunk] (Set.Set Global)
158 | PortIncoming Expr (Set.Set Global)
146 | PortIncoming Expr (Set.Set Global)
159 | PortOutgoing Expr (Set.Set Global)
147 | PortOutgoing Expr (Set.Set Global)
160
148
@@ -162,21 +150,6 @@ data Node
162data EffectsType = Cmd | Sub | Fx
150data EffectsType = Cmd | Sub | Fx
163
151
164
152
165−data KContent =
166− KContent [KChunk] (Set.Set Global)
167−
168−
169−data KChunk
170− = JS BS.ByteString
171− | ElmVar ModuleName.Canonical Name
172− | JsVar Name Name
173− | ElmField Name
174− | JsField Int
175− | JsEnum Int
176− | Debug
177− | Prod
178−
179−
180
153
181-- BINARY
154-- BINARY
182
155
@@ -383,34 +356,3 @@ instance Binary EffectsType where
383 1 -> return Sub
356 1 -> return Sub
384 2 -> return Fx
357 2 -> return Fx
385 _ -> error "problem getting Opt.EffectsType binary"
358 _ -> error "problem getting Opt.EffectsType binary"
386−
387−
388−instance Binary KContent where
389− get = liftM2 KContent get get
390− put (KContent a b) = put a >> put b
391−
392−
393−instance Binary KChunk where
394− put chunk =
395− case chunk of
396− JS a -> putWord8 0 >> put a
397− ElmVar a b -> putWord8 1 >> put a >> put b
398− JsVar a b -> putWord8 2 >> put a >> put b
399− ElmField a -> putWord8 3 >> put a
400− JsField a -> putWord8 4 >> put a
401− JsEnum a -> putWord8 5 >> put a
402− Debug -> putWord8 6
403− Prod -> putWord8 7
404−
405− get =
406− do word <- getWord8
407− case word of
408− 0 -> liftM JS get
409− 1 -> liftM2 ElmVar get get
410− 2 -> liftM2 JsVar get get
411− 3 -> liftM ElmField get
412− 4 -> liftM JsField get
413− 5 -> liftM JsEnum get
414− 6 -> return Debug
415− 7 -> return Prod
416− _ -> error "problem deserializing AST.Optimized.KChunk"
compiler/src/Elm/Kernel.hs+234−122
@@ -1,62 +1,225 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE EmptyDataDecls, OverloadedStrings, UnboxedTuples #-}
3module Elm.Kernel
3module Elm.Kernel
4− ( Opt.KContent(..)
4+ ( Content(..)
5− , parse
5+ , Chunk(..)
6+ , Dep(..)
7+ , parser
6 )
8 )
7 where
9 where
8
10
9
11
10−import qualified Data.ByteString as B
12+import Control.Monad (liftM, liftM2)
13+import Data.Binary (Binary, get, put, getWord8, putWord8)
14+import Data.Coerce (coerce)
11import qualified Data.List as List
15import qualified Data.List as List
12import qualified Data.Map as Map
16import qualified Data.Map as Map
13import qualified Data.Name as Name
17import qualified Data.Name as Name
14import qualified Data.Set as Set
18import qualified Data.Set as Set
19+import qualified Data.Utf8 as Utf8
15−import Data.Word (Word8)
20+import Data.Word (Word8, Word16)
21+import Foreign.Ptr (Ptr, plusPtr)
16
22
17−
18−import qualified AST.Optimized as Opt
19import qualified AST.Source as Src
23import qualified AST.Source as Src
20import qualified Elm.ModuleName as ModuleName
24import qualified Elm.ModuleName as ModuleName
21import qualified Elm.Package as Pkg
25import qualified Elm.Package as Pkg
22−import Parse.Primitives (Parser, run)
23−import qualified Parse.Primitives.Kernel as K
24−import qualified Parse.Primitives.Symbol as Symbol
25import qualified Parse.Module as Module
26import qualified Parse.Module as Module
27+import qualified Parse.Variable as Var
28+import Parse.Utils
29+import Parse.Primitives hiding (Parser, State)
30+import qualified Parse.Primitives as P
26import qualified Reporting.Annotation as A
31import qualified Reporting.Annotation as A
27−import qualified Reporting.Error as E
32+import qualified Reporting.Error.Syntax as E
28
33
29
34
30
35
31−-- PARSE
36+-- CONTENT
32
37
33
38
34−type ImportDict =
39+data Content =
35− Map.Map Name.Name [Pkg.Name]
40+ Content [Chunk] (Set.Set Dep)
41+
42+
43+data Dep
44+ = ElmDep ModuleName.Canonical Name.Name
45+ | KernelDep Name.Name
46+ deriving (Eq, Ord)
47+
48+
49+
50+-- CHUNKS
36
51
37
52
38−parse :: ImportDict -> B.ByteString -> Either E.Error Opt.KContent
53+data Chunk
39−parse importDict sourceCode =
54+ = JS (Utf8.VeryLong UNCHECKED)
40− case run (parser importDict) sourceCode of
55+ | ElmVar ModuleName.Canonical Name.Name
41− Right kernel ->
56+ | JsVar Name.Name Name.Name
42− Right kernel
57+ | ElmField Name.Name
58+ | JsField Int
59+ | JsEnum Int
60+ | Debug
61+ | Prod
43
62
44− Left err ->
45− Left (E.Syntax err)
46
63
64+data UNCHECKED
65+
66+
67+
68+-- PARSE
69+
70+
71+type ImportDict =
72+ Map.Map Name.Name [Pkg.Name]
47
73
74+
48−parser :: ImportDict -> Parser Opt.KContent
75+parser :: ImportDict -> Parser Content
49parser importDict =
76parser importDict =
50− do Symbol.jsMultiCommentOpen
77+ do word2 0x2F 0x2A {-/*-} E.XXX
51 Module.freshLine
78 Module.freshLine
52 imports <- Module.chompImports []
79 imports <- Module.chompImports []
53− Symbol.jsMultiCommentClose
80+ word2 0x2A 0x2F {-*/-} E.XXX
81+ let (vtable, deps) = processImports importDict imports
82+ chunks <- parseChunks vtable Map.empty Map.empty
83+ return $ Content chunks deps
84+
85+
86+
87+-- PARSE CHUNKS
88+
89+
90+parseChunks :: VarTable -> Enums -> Fields -> Parser [Chunk]
91+parseChunks vtable enums fields =
92+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr _ ->
93+ let
94+ (# chunks, newPos, newRow, newCol #) =
95+ chompChunks vtable enums fields pos end row col pos []
96+ in
97+ if newPos == end then
98+ cok chunks (P.State newPos end indent newRow newCol ctx)
99+ else
100+ cerr row col ctx E.XXX
101+
54
102
55− let (State vtable deps) = processImports importDict imports
103+addJS :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
104+addJS start end revChunks =
105+ if start == end
106+ then revChunks
107+ else JS (Utf8.fromPtr start end) : revChunks
56
108
57− chunks <- chompChunks vtable Map.empty Map.empty []
58
109
59− return $ Opt.KContent chunks deps
110+chompChunks :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
111+chompChunks vs es fs pos end row col lastPos revChunks =
112+ if pos >= end then
113+ (# reverse (addJS lastPos end revChunks), pos, row, col #)
114+
115+ else
116+ let !word = unsafeIndex pos in
117+ if word == 0x5F {-_-} then
118+ let
119+ !pos1 = plusPtr pos 1
120+ !pos3 = plusPtr pos 3
121+ in
122+ if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
123+ chompTag vs es fs pos3 end row (col + 3) (addJS lastPos pos revChunks)
124+ else
125+ chompChunks vs es fs pos1 end row (col + 1) lastPos revChunks
126+
127+ else if word == 0x0A {-\n-} then
128+ chompChunks vs es fs (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
129+
130+ else
131+ let
132+ !newPos = plusPtr pos (getCharWidth pos end word)
133+ in
134+ chompChunks vs es fs newPos end row (col + 1) lastPos revChunks
135+
136+
137+-- relies on external checks in chompChunks
138+chompTag :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
139+chompTag vs es fs pos end row col revChunks =
140+ let
141+ (# newPos, newCol #) = Var.chompInnerChars pos end col
142+ !tagPos = plusPtr pos (-1)
143+ !word = unsafeIndex tagPos
144+ in
145+ if word == 0x24 {-$-} then
146+ chompChunks vs es fs newPos end row newCol newPos $
147+ ElmField (Name.fromPtr pos newPos) : revChunks
148+ else
149+ let
150+ !name = Name.fromPtr tagPos newPos
151+ in
152+ if 0x30 {-0-} <= word && word <= 0x39 {-9-} then
153+ let
154+ (enum, newEnums) =
155+ lookupEnum (word - 0x30) name es
156+ in
157+ chompChunks vs newEnums fs newPos end row newCol newPos $
158+ JsEnum enum : revChunks
159+
160+ else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
161+ let
162+ (field, newFields) =
163+ lookupField name fs
164+ in
165+ chompChunks vs es newFields newPos end row newCol newPos $
166+ JsField field : revChunks
167+
168+ else if name == "DEBUG" then
169+ chompChunks vs es fs newPos end row newCol newPos (Debug : revChunks)
170+
171+ else if name == "PROD" then
172+ chompChunks vs es fs newPos end row newCol newPos (Prod : revChunks)
173+
174+ else
175+ case Map.lookup name vs of
176+ Just chunk ->
177+ chompChunks vs es fs newPos end row newCol newPos (chunk : revChunks)
178+
179+ Nothing ->
180+ (# revChunks, pos, row, col #)
181+
182+
183+
184+-- FIELDS
185+
186+
187+type Fields =
188+ Map.Map Name.Name Int
189+
190+
191+lookupField :: Name.Name -> Fields -> (Int, Fields)
192+lookupField name fields =
193+ case Map.lookup name fields of
194+ Just n ->
195+ ( n, fields )
196+
197+ Nothing ->
198+ let n = Map.size fields in
199+ ( n, Map.insert name n fields )
200+
201+
202+
203+-- ENUMS
204+
205+
206+type Enums =
207+ Map.Map Word8 (Map.Map Name.Name Int)
208+
209+
210+lookupEnum :: Word8 -> Name.Name -> Enums -> (Int, Enums)
211+lookupEnum word var allEnums =
212+ let
213+ enums =
214+ Map.findWithDefault Map.empty word allEnums
215+ in
216+ case Map.lookup var enums of
217+ Just n ->
218+ ( n, allEnums )
219+
220+ Nothing ->
221+ let n = Map.size enums in
222+ ( n, Map.insert word (Map.insert var n enums) allEnums )
60
223
61
224
62
225
@@ -64,16 +227,16 @@ parser importDict =
64
227
65
228
66type VarTable =
229type VarTable =
67− Map.Map Name.Name Opt.KChunk
230+ Map.Map Name.Name Chunk
68
231
69
232
70−data State =
233+type State =
71− State VarTable (Set.Set Opt.Global)
234+ (VarTable, Set.Set Dep)
72
235
73
236
74processImports :: ImportDict -> [Src.Import] -> State
237processImports :: ImportDict -> [Src.Import] -> State
75processImports importDict imports =
238processImports importDict imports =
76− List.foldl' (addImport importDict) (State Map.empty Set.empty) imports
239+ List.foldl' (addImport importDict) (Map.empty, Set.empty) imports
77
240
78
241
79addImport :: ImportDict -> State -> Src.Import -> State
242addImport :: ImportDict -> State -> Src.Import -> State
@@ -81,7 +244,7 @@ addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =
81 if Name.isKernel home then
244 if Name.isKernel home then
82 case maybeAlias of
245 case maybeAlias of
83 Just _ ->
246 Just _ ->
84− error ("Cannot use aliases on kernel import of: " ++ Name.toString home)
247+ error ("Cannot use aliases on kernel import of: " ++ Name.toChars home)
85
248
86 Nothing ->
249 Nothing ->
87 addKernelImport (Name.getKernel home) exposing state
250 addKernelImport (Name.getKernel home) exposing state
@@ -96,29 +259,29 @@ addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =
96 addNormalImport canonicalHome prefix exposing state
259 addNormalImport canonicalHome prefix exposing state
97
260
98 _ ->
261 _ ->
99− error ("Cannot find kernel import of: " ++ Name.toString home)
262+ error ("Cannot find kernel import of: " ++ Name.toChars home)
100
263
101
264
102-- INVARIANT: the `home` is the * in `Elm.Kernel.*`
265-- INVARIANT: the `home` is the * in `Elm.Kernel.*`
103--
266--
104addKernelImport :: Name.Name -> Src.Exposing -> State -> State
267addKernelImport :: Name.Name -> Src.Exposing -> State -> State
105−addKernelImport home exposing (State vtable deps) =
268+addKernelImport home exposing (vtable, deps) =
106 let
269 let
107 addVar table name =
270 addVar table name =
108− Map.insert (Name.sepBy 0x5F {- _ -} home name) (Opt.JsVar home name) table
271+ Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table
109 in
272 in
110− State
111− (List.foldl' addVar vtable (toNames exposing))
273+ ( List.foldl' addVar vtable (toNames exposing)
112− (Set.insert (Opt.kernel home) deps)
274+ , Set.insert (KernelDep home) deps
275+ )
113
276
114
277
115addNormalImport :: ModuleName.Canonical -> Name.Name -> Src.Exposing -> State -> State
278addNormalImport :: ModuleName.Canonical -> Name.Name -> Src.Exposing -> State -> State
116addNormalImport home prefix exposing state =
279addNormalImport home prefix exposing state =
117 let
280 let
118− addVar (State vtable deps) name =
281+ addVar (vtable, deps) name =
119− State
120− (Map.insert (Name.sepBy 0x5F {- _ -} prefix name) (Opt.ElmVar home name) vtable)
282+ ( Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) vtable
121− (Set.insert (Opt.Global home name) deps)
283+ , Set.insert (ElmDep home name) deps
284+ )
122 in
285 in
123 List.foldl' addVar state (toNames exposing)
286 List.foldl' addVar state (toNames exposing)
124
287
@@ -131,10 +294,11 @@ toPrefix home maybeAlias =
131
294
132 Nothing ->
295 Nothing ->
133 if Name.hasDot home then
296 if Name.hasDot home then
134− error ("kernel imports with dots need an alias: " ++ show (Name.toString home))
297+ error ("kernel imports with dots need an alias: " ++ show (Name.toChars home))
135 else
298 else
136 home
299 home
137
300
301+
138toNames :: Src.Exposing -> [Name.Name]
302toNames :: Src.Exposing -> [Name.Name]
139toNames exposing =
303toNames exposing =
140 case exposing of
304 case exposing of
@@ -162,87 +326,35 @@ toName (A.At _ exposed) =
162
326
163
327
164
328
165−-- PARSE CHUNKS
329+-- BINARY
166−
167−
168−chompChunks :: VarTable -> Enums -> Fields -> [Opt.KChunk] -> Parser [Opt.KChunk]
169−chompChunks vtable enums fields chunks =
170− do (javascript, maybeTag) <- K.chunk
171− case maybeTag of
172− Nothing ->
173− return (Opt.JS javascript : chunks)
174−
175− Just tag ->
176− case tag of
177− K.Prod ->
178− chompChunks vtable enums fields $
179− Opt.Prod : Opt.JS javascript : chunks
180−
181− K.Debug ->
182− chompChunks vtable enums fields $
183− Opt.Debug : Opt.JS javascript : chunks
184−
185− K.Import var ->
186− case Map.lookup var vtable of
187− Nothing ->
188− error ("Bad kernel symbol: " ++ Name.toString var)
189−
190− Just chunk ->
191− chompChunks vtable enums fields $
192− chunk : Opt.JS javascript : chunks
193−
194− K.Enum n var ->
195− let (enum, newEnums) = lookupEnum n var enums in
196− chompChunks vtable newEnums fields $
197− Opt.JsEnum enum : Opt.JS javascript : chunks
198−
199− K.ElmField name ->
200− chompChunks vtable enums fields $
201− Opt.ElmField name : Opt.JS javascript : chunks
202−
203− K.JsField name ->
204− let (field, newFields) = lookupField name fields in
205− chompChunks vtable enums newFields $
206− Opt.JsField field : Opt.JS javascript : chunks
207−
208−
209−
210−-- FIELDS
211−
212−
213−type Fields =
214− Map.Map Name.Name Int
215−
216−
217−lookupField :: Name.Name -> Fields -> (Int, Fields)
218−lookupField name fields =
219− case Map.lookup name fields of
220− Just n ->
221− ( n, fields )
222−
223− Nothing ->
224− let n = Map.size fields in
225− ( n, Map.insert name n fields )
226−
227−
228−
229−-- ENUMS
230
330
231
331
232−type Enums =
332+instance Binary Chunk where
233− Map.Map Word8 (Map.Map Name.Name Int)
333+ put chunk =
334+ case chunk of
335+ JS a -> putWord8 0 >> put (coerce a :: Utf8.String)
336+ ElmVar a b -> putWord8 1 >> put a >> put b
337+ JsVar a b -> putWord8 2 >> put a >> put b
338+ ElmField a -> putWord8 3 >> put a
339+ JsField a -> putWord8 4 >> put a
340+ JsEnum a -> putWord8 5 >> put a
341+ Debug -> putWord8 6
342+ Prod -> putWord8 7
234
343
344+ get =
345+ do word <- getWord8
346+ case word of
347+ 0 -> liftM toJS get
348+ 1 -> liftM2 ElmVar get get
349+ 2 -> liftM2 JsVar get get
350+ 3 -> liftM ElmField get
351+ 4 -> liftM JsField get
352+ 5 -> liftM JsEnum get
353+ 6 -> return Debug
354+ 7 -> return Prod
355+ _ -> error "problem deserializing Elm.Kernel.Chunk"
235
356
236−lookupEnum :: Word8 -> Name.Name -> Enums -> (Int, Enums)
237−lookupEnum word var allEnums =
238− let
239− enums =
240− Map.findWithDefault Map.empty word allEnums
241− in
242− case Map.lookup var enums of
243− Just n ->
244− ( n, allEnums )
245
357
246− Nothing ->
358+toJS :: Utf8.String -> Chunk
247− let n = Map.size enums in
359+toJS str =
248− ( n, Map.insert word (Map.insert var n enums) allEnums )
360+ JS (coerce str)