@@ -1,62 +1,225 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE EmptyDataDecls, OverloadedStrings, UnboxedTuples #-}
33module Elm.Kernel
4− ( Opt.KContent(..)
5− , parse
4+ ( Content(..)
5+ , Chunk(..)
6+ , Dep(..)
7+ , parser
68 )
79 where
810
911
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)
1115import qualified Data.List as List
1216import qualified Data.Map as Map
1317import qualified Data.Name as Name
1418import qualified Data.Set as Set
15−import Data.Word (Word8)
19+import qualified Data.Utf8 as Utf8
20+import Data.Word (Word8, Word16)
21+import Foreign.Ptr (Ptr, plusPtr)
1622
17−
18−import qualified AST.Optimized as Opt
1923import qualified AST.Source as Src
2024import qualified Elm.ModuleName as ModuleName
2125import 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
2526import 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
2631import qualified Reporting.Annotation as A
27−import qualified Reporting.Error as E
32+import qualified Reporting.Error.Syntax as E
2833
2934
3035
31−-- PARSE
36+-- CONTENT
3237
3338
34−type ImportDict =
35− Map.Map Name.Name [Pkg.Name]
39+data Content =
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
3651
3752
38−parse :: ImportDict -> B.ByteString -> Either E.Error Opt.KContent
39−parse importDict sourceCode =
40− case run (parser importDict) sourceCode of
41− Right kernel ->
42− Right kernel
53+data Chunk
54+ = JS (Utf8.VeryLong UNCHECKED)
55+ | ElmVar ModuleName.Canonical Name.Name
56+ | JsVar Name.Name Name.Name
57+ | ElmField Name.Name
58+ | JsField Int
59+ | JsEnum Int
60+ | Debug
61+ | Prod
4362
44− Left err ->
45− Left (E.Syntax err)
4663
64+data UNCHECKED
65+
66+
67+
68+-- PARSE
69+
70+
71+type ImportDict =
72+ Map.Map Name.Name [Pkg.Name]
4773
48−parser :: ImportDict -> Parser Opt.KContent
74+
75+parser :: ImportDict -> Parser Content
4976parser importDict =
50− do Symbol.jsMultiCommentOpen
77+ do word2 0x2F 0x2A {-/*-} E.XXX
5178 Module.freshLine
5279 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+
54102
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
56108
57− chunks <- chompChunks vtable Map.empty Map.empty []
58109
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 )
60223
61224
62225
@@ -64,16 +227,16 @@ parser importDict =
64227
65228
66229type VarTable =
67− Map.Map Name.Name Opt.KChunk
230+ Map.Map Name.Name Chunk
68231
69232
70−data State =
71− State VarTable (Set.Set Opt.Global)
233+type State =
234+ (VarTable, Set.Set Dep)
72235
73236
74237processImports :: ImportDict -> [Src.Import] -> State
75238processImports importDict imports =
76− List.foldl' (addImport importDict) (State Map.empty Set.empty) imports
239+ List.foldl' (addImport importDict) (Map.empty, Set.empty) imports
77240
78241
79242addImport :: ImportDict -> State -> Src.Import -> State
@@ -81,7 +244,7 @@ addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =
81244 if Name.isKernel home then
82245 case maybeAlias of
83246 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)
85248
86249 Nothing ->
87250 addKernelImport (Name.getKernel home) exposing state
@@ -96,29 +259,29 @@ addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =
96259 addNormalImport canonicalHome prefix exposing state
97260
98261 _ ->
99− error ("Cannot find kernel import of: " ++ Name.toString home)
262+ error ("Cannot find kernel import of: " ++ Name.toChars home)
100263
101264
102265-- INVARIANT: the `home` is the * in `Elm.Kernel.*`
103266--
104267addKernelImport :: Name.Name -> Src.Exposing -> State -> State
105−addKernelImport home exposing (State vtable deps) =
268+addKernelImport home exposing (vtable, deps) =
106269 let
107270 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
109272 in
110− State
111− (List.foldl' addVar vtable (toNames exposing))
112− (Set.insert (Opt.kernel home) deps)
273+ ( List.foldl' addVar vtable (toNames exposing)
274+ , Set.insert (KernelDep home) deps
275+ )
113276
114277
115278addNormalImport :: ModuleName.Canonical -> Name.Name -> Src.Exposing -> State -> State
116279addNormalImport home prefix exposing state =
117280 let
118− addVar (State vtable deps) name =
119− State
120− (Map.insert (Name.sepBy 0x5F {- _ -} prefix name) (Opt.ElmVar home name) vtable)
121− (Set.insert (Opt.Global home name) deps)
281+ addVar (vtable, deps) name =
282+ ( Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) vtable
283+ , Set.insert (ElmDep home name) deps
284+ )
122285 in
123286 List.foldl' addVar state (toNames exposing)
124287
@@ -131,10 +294,11 @@ toPrefix home maybeAlias =
131294
132295 Nothing ->
133296 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))
135298 else
136299 home
137300
301+
138302toNames :: Src.Exposing -> [Name.Name]
139303toNames exposing =
140304 case exposing of
@@ -162,87 +326,35 @@ toName (A.At _ exposed) =
162326
163327
164328
165−-- PARSE CHUNKS
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
329+-- BINARY
230330
231331
232−type Enums =
233− Map.Map Word8 (Map.Map Name.Name Int)
332+instance Binary Chunk where
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
234343
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"
235356
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 )
245357
246− Nothing ->
247− let n = Map.size enums in
248− ( n, Map.insert word (Map.insert var n enums) allEnums )
358+toJS :: Utf8.String -> Chunk
359+toJS str =
360+ JS (coerce str)