@@ -1,15 +1,17 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
33module Elm.Kernel
4− ( Kernel(..)
4+ ( Opt.KContent(..)
55 , parse
66 )
77 where
88
99
1010import qualified Data.ByteString as B
11+import qualified Data.List as List
1112import qualified Data.Map as Map
1213import Data.Monoid ((<>))
14+import qualified Data.Set as Set
1315import qualified Data.Text as Text
1416import Data.Word (Word8)
1517
@@ -18,6 +20,7 @@ import qualified AST.Optimized as Opt
1820import qualified AST.Source as Src
1921import qualified AST.Module.Name as ModuleName
2022import qualified Elm.Name as N
23+import qualified Elm.Package as Pkg
2124import Parse.Primitives (Parser, run)
2225import qualified Parse.Primitives.Kernel as K
2326import qualified Parse.Primitives.Symbol as Symbol
@@ -30,16 +33,13 @@ import qualified Reporting.Error as E
3033-- PARSE
3134
3235
33−data Kernel =
34− Kernel
35− { _imports :: [(N.Name, N.Name)]
36− , _chunks :: [Opt.KChunk]
37− }
36+type ImportDict =
37+ Map.Map N.Name [Pkg.Name]
3838
3939
40−parse :: B.ByteString -> Either E.Error Kernel
41−parse sourceCode =
42− case run parser sourceCode of
40+parse :: ImportDict -> B.ByteString -> Either E.Error Opt.KContent
41+parse importDict sourceCode =
42+ case run (parser importDict) sourceCode of
4343 Right kernel ->
4444 Right kernel
4545
@@ -47,23 +47,128 @@ parse sourceCode =
4747 Left (E.Syntax err)
4848
4949
50−
51−-- PARSER
52−
53−
54−parser :: Parser Kernel
55−parser =
50+parser :: ImportDict -> Parser Opt.KContent
51+parser importDict =
5652 do Symbol.jsMultiCommentOpen
5753 Module.freshLine
58− srcImports <- Module.chompImports []
54+ imports <- Module.chompImports []
5955 Symbol.jsMultiCommentClose
60− let imports = Map.unions (map destructImport srcImports)
61− chunks <- parserHelp imports Map.empty Map.empty []
62− return $ Kernel (Map.elems imports) chunks
56+
57+ let (State vtable deps) = processImports importDict imports
58+
59+ chunks <- chompChunks vtable Map.empty Map.empty []
60+
61+ return $ Opt.KContent chunks deps
62+
63+
64+
65+-- PROCESS IMPORTS
66+
67+
68+type VarTable =
69+ Map.Map Text.Text Opt.KChunk
70+
71+
72+data State =
73+ State VarTable (Set.Set Opt.Global)
74+
75+
76+processImports :: ImportDict -> [Src.Import] -> State
77+processImports importDict imports =
78+ List.foldl' (addImport importDict) (State Map.empty Set.empty) imports
79+
80+
81+addImport :: ImportDict -> State -> Src.Import -> State
82+addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =
83+ if ModuleName.isKernel home then
84+ case maybeAlias of
85+ Just _ ->
86+ error ("Cannot use aliases on kernel import of: " ++ show home)
87+
88+ Nothing ->
89+ addKernelImport (ModuleName.getKernel home) exposing state
90+
91+ else
92+ case Map.lookup home importDict of
93+ Just [pkg] ->
94+ let
95+ canonicalHome = ModuleName.Canonical pkg home
96+ prefix = toPrefix home maybeAlias
97+ in
98+ addNormalImport canonicalHome prefix exposing state
99+
100+ _ ->
101+ error ("Cannot find kernel import of: " ++ show home)
102+
103+
104+-- INVARIANT: the `home` is the * in `Elm.Kernel.*`
105+--
106+addKernelImport :: N.Name -> Src.Exposing -> State -> State
107+addKernelImport home exposing (State vtable deps) =
108+ let
109+ addVar table name =
110+ Map.insert (home <> "_" <> name) (Opt.JsVar home name) table
111+ in
112+ State
113+ (List.foldl' addVar vtable (toNames exposing))
114+ (Set.insert (Opt.kernel home) deps)
115+
116+
117+addNormalImport :: ModuleName.Canonical -> N.Name -> Src.Exposing -> State -> State
118+addNormalImport home prefix exposing state =
119+ let
120+ addVar (State vtable deps) name =
121+ State
122+ (Map.insert (prefix <> "_" <> name) (Opt.ElmVar home name) vtable)
123+ (Set.insert (Opt.Global home name) deps)
124+ in
125+ List.foldl' addVar state (toNames exposing)
126+
127+
128+toPrefix :: N.Name -> Maybe N.Name -> N.Name
129+toPrefix home maybeAlias =
130+ case maybeAlias of
131+ Just alias ->
132+ alias
133+
134+ Nothing ->
135+ if Text.isInfixOf "." home then
136+ error ("kernel imports with dots need an alias: " ++ show home)
137+ else
138+ home
139+
140+toNames :: Src.Exposing -> [N.Name]
141+toNames exposing =
142+ case exposing of
143+ Src.Open ->
144+ error "Cannot have `exposing (..)` in kernel code."
145+
146+ Src.Explicit exposedList ->
147+ map toName exposedList
148+
149+
150+toName :: A.Located Src.Exposed -> N.Name
151+toName (A.At _ exposed) =
152+ case exposed of
153+ Src.Lower name ->
154+ name
155+
156+ Src.Upper name Src.Private ->
157+ name
158+
159+ Src.Upper _ Src.Public ->
160+ error "cannot have Maybe(..) syntax in kernel code header"
161+
162+ Src.Operator _ ->
163+ error "cannot use binops in kernel code"
63164
64165
65−parserHelp :: Imports -> Enums -> Fields -> [Opt.KChunk] -> Parser [Opt.KChunk]
66−parserHelp imports enums fields chunks =
166+
167+-- PARSE CHUNKS
168+
169+
170+chompChunks :: VarTable -> Enums -> Fields -> [Opt.KChunk] -> Parser [Opt.KChunk]
171+chompChunks vtable enums fields chunks =
67172 do (javascript, maybeTag) <- K.chunk
68173 case maybeTag of
69174 Nothing ->
@@ -72,34 +177,34 @@ parserHelp imports enums fields chunks =
72177 Just tag ->
73178 case tag of
74179 K.Prod ->
75− parserHelp imports enums fields $
180+ chompChunks vtable enums fields $
76181 Opt.Prod : Opt.JS javascript : chunks
77182
78183 K.Debug ->
79− parserHelp imports enums fields $
184+ chompChunks vtable enums fields $
80185 Opt.Debug : Opt.JS javascript : chunks
81186
82187 K.Import var ->
83− case Map.lookup var imports of
188+ case Map.lookup var vtable of
84189 Nothing ->
85190 error ("Bad kernel symbol: " ++ Text.unpack var)
86191
87− Just (home, name) ->
88− parserHelp imports enums fields $
89− Opt.Var home name : Opt.JS javascript : chunks
192+ Just chunk ->
193+ chompChunks vtable enums fields $
194+ chunk : Opt.JS javascript : chunks
90195
91196 K.Enum n var ->
92197 let (enum, newEnums) = lookupEnum n var enums in
93− parserHelp imports newEnums fields $
198+ chompChunks vtable newEnums fields $
94199 Opt.Enum enum : Opt.JS javascript : chunks
95200
96201 K.ElmField name ->
97− parserHelp imports enums fields $
202+ chompChunks vtable enums fields $
98203 Opt.ElmField name : Opt.JS javascript : chunks
99204
100205 K.JsField name ->
101206 let (field, newFields) = lookupField name fields in
102− parserHelp imports enums newFields $
207+ chompChunks vtable enums newFields $
103208 Opt.JsField field : Opt.JS javascript : chunks
104209
105210
@@ -143,55 +248,3 @@ lookupEnum word var allEnums =
143248 Nothing ->
144249 let n = Map.size enums in
145250 ( n, Map.insert word (Map.insert var n enums) allEnums )
146−
147−
148−
149−-- IMPORTS
150−
151−
152−type Imports =
153− Map.Map Text.Text (N.Name, N.Name)
154−
155−
156−destructImport :: Src.Import -> Imports
157−destructImport (Src.Import (A.At _ moduleName) maybeAlias exposing) =
158− let
159− shortName =
160− case maybeAlias of
161− Just alias ->
162− alias
163−
164− Nothing ->
165− if ModuleName.isKernel moduleName then
166− ModuleName.getKernel moduleName
167− else if Text.isInfixOf "." moduleName then
168− error ("modules with dots in kernel code need an alias: " ++ show moduleName)
169− else
170− moduleName
171−
172− toEntry name =
173− ( shortName <> "_" <> name, ( moduleName, name ) )
174− in
175− Map.fromList $ map toEntry $
176− case exposing of
177− Src.Open ->
178− error "cannot have open imports in kernel code"
179−
180− Src.Explicit exposed ->
181− map exposedToName exposed
182−
183−
184−exposedToName :: A.Located Src.Exposed -> N.Name
185−exposedToName (A.At _ exposed) =
186− case exposed of
187− Src.Lower name ->
188− name
189−
190− Src.Upper name Src.Private ->
191− name
192−
193− Src.Upper _ Src.Public ->
194− error "cannot have Maybe(..) syntax in kernel code header"
195−
196− Src.Operator _ ->
197− error "cannot use binops in kernel code"