@@ -2,217 +2,357 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Generate.JavaScript
44 ( generate
5− , Target(..)
5+ , Roots(..)
66 )
77 where
88
9−import Control.Monad (foldM)
9+
10+import Prelude hiding (cycle)
11+import qualified Data.ByteString.Builder as B
1012import Data.Monoid ((<>))
1113import qualified Data.List as List
14+import Data.Map ((!))
1215import qualified Data.Map as Map
1316import qualified Data.Set as Set
14−import qualified Data.Text as Text
15−import qualified Data.Text.Encoding as Text
16−import qualified Data.ByteString.Builder as BS
1717
18−import qualified AST.Effects as Effects
19−import qualified AST.Expression.Optimized as Opt
20−import qualified AST.Kernel as Kernel
18+import qualified AST.Optimized as Opt
2119import qualified AST.Module.Name as ModuleName
22−import qualified AST.Variable as Var
20+import qualified Elm.Name as N
2321import qualified Elm.Package as Pkg
24−import qualified Elm.Compiler.Objects.Internal as Obj
25−import qualified Generate.JavaScript.Builder as JsBuilder
26−import qualified Generate.JavaScript.Effects as JsEffects
27−import qualified Generate.JavaScript.Expression as JsExpr
28−import qualified Generate.JavaScript.Variable as JS
22+import qualified Generate.JavaScript.Builder as JS
23+import qualified Generate.JavaScript.Expression as Expr
24+import qualified Generate.JavaScript.Name as Name
2925
3026
3127
32−-- GENERATE JAVASCRIPT
28+-- GENERATE
3329
3430
35−generate :: Bool -> Target -> Obj.Graph -> Obj.Roots -> BS.Builder
36−generate debug target graph roots =
37− let
38− (State builders _ _ effects) =
39− List.foldl' (crawl (Env debug target) graph) initialState (Obj.toGlobals roots)
31+data Roots
32+ = Mains [ModuleName.Canonical]
33+ | Value ModuleName.Canonical N.Name
4034
41− managers =
42− JS.run (JsEffects.generate effects)
43− in
44− List.foldl' (\rest stmt -> stmt <> rest) managers builders
4535
36+generate :: Bool -> Name.Target -> Opt.Graph -> Roots -> Either [ModuleName.Canonical] B.Builder
37+generate debug target (Opt.Graph mains nodes fields) roots =
38+ case roots of
39+ Value home name ->
40+ Right $ stateToBuilder $
41+ addGlobal (toMode debug target fields) nodes emptyState (Opt.Global home name)
4642
43+ Mains modules ->
44+ generateMain (toMode debug target fields) nodes
45+ <$> verifyMains mains modules
4746
48−-- CRAWL ENV
4947
50−
51−data Env =
52− Env
53− { _debug :: Bool
54− , _target :: Target
55− }
56−
57−
58−data Target = Client | Server
48+toMode :: Bool -> Name.Target -> Map.Map N.Name Int -> Name.Mode
49+toMode debug target fields =
50+ if debug then
51+ Name.Debug target
52+ else
53+ Name.Prod target (Name.shortenFieldNames fields)
5954
6055
6156
62−-- CRAWL STATE
57+-- GRAPH TRAVERSAL STATE
6358
6459
6560data State =
6661 State
67− { _builders :: [BS.Builder]
68− , _seenDecls :: Set.Set Var.Global
69− , _seenKernels :: Set.Set ModuleName.Raw
70− , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
62+ { _revBuilders :: [B.Builder]
63+ , _seenGlobals :: Set.Set Opt.Global
7164 }
7265
7366
74−initialState :: State
75−initialState =
76− State [] Set.empty Set.empty Map.empty
67+emptyState :: State
68+emptyState =
69+ State [] Set.empty
7770
7871
72+stateToBuilder :: State -> B.Builder
73+stateToBuilder (State revBuilders _) =
74+ List.foldl1' (\builder b -> b <> builder) revBuilders
7975
80−-- CRAWL
8176
8277
83−crawl :: Env -> Obj.Graph -> State -> Var.Global -> State
84−crawl env graph@(Obj.Graph decls kernels) state@(State _ seenDecls seenKernels _) name@(Var.Global home _) =
85− if Set.member name seenDecls then
86− state
78+-- ADD DEPENDENCIES
79+
80+
81+type Mode = Name.Mode
82+type Graph = Map.Map Opt.Global Opt.Node
8783
88− else if home == virtualDomDebug then
89− state
9084
85+addGlobal :: Mode -> Graph -> State -> Opt.Global -> State
86+addGlobal mode graph state@(State builders seen) global =
87+ if Set.member global seen then
88+ state
9189 else
92− case Map.lookup name decls of
93− Just decl ->
94− crawlDecl env graph name decl state
90+ addGlobalHelp mode graph global $
91+ State builders (Set.insert global seen)
92+
93+
94+addGlobalHelp :: Mode -> Graph -> Opt.Global -> State -> State
95+addGlobalHelp mode graph global state =
96+ let
97+ addDeps deps someState =
98+ Set.foldl' (addGlobal mode graph) someState deps
99+ in
100+ case graph ! global of
101+ Opt.Define expr deps ->
102+ addStmt (addDeps deps state) (
103+ var global (Expr.generate mode expr)
104+ )
105+
106+ Opt.DefineTailFunc argNames body deps ->
107+ addStmt (addDeps deps state) (
108+ var global (Expr.generateFunction (map Name.fromLocal argNames) (Expr.generate mode body))
109+ )
95110
96− Nothing ->
97− let
98− kernelModule =
99− ModuleName._module home
100− in
101− if Set.member kernelModule seenKernels then
102− state
103− else
104− case Map.lookup kernelModule kernels of
105− Just info ->
106− crawlKernel env graph kernelModule info state
111+ Opt.Ctor name index arity ->
112+ let (args, ctor) = Expr.generateCtor mode name index arity in
113+ addStmt state (
114+ var global (Expr.generateFunction args ctor)
115+ )
107116
108− Nothing ->
109− error (crawlError name)
117+ Opt.Link linkedGlobal ->
118+ addGlobal mode graph state linkedGlobal
110119
120+ Opt.Cycle cycle deps ->
121+ addStmt (addDeps deps state) (
122+ generateCycle mode global cycle
123+ )
111124
125+ Opt.Manager effectsType ->
126+ generateManager mode graph global effectsType state
112127
113−-- CRAWL DECL
128+ Opt.Kernel clientChunks clientDeps maybeServer ->
129+ case maybeServer of
130+ Just (serverChunks, serverDeps) | Name.isServer mode ->
131+ addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
114132
133+ _ ->
134+ addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
115135
116−crawlDecl :: Env -> Obj.Graph -> Var.Global -> Opt.Decl -> State -> State
117−crawlDecl env graph var@(Var.Global home name) (Opt.Decl direct indirect fx body) state1 =
136+ Opt.PortIncoming decoder deps ->
137+ addStmt (addDeps deps state) (
138+ generatePort mode global "incomingPort" decoder
139+ )
140+
141+ Opt.PortOutgoing encoder deps ->
142+ addStmt (addDeps deps state) (
143+ generatePort mode global "outgoingPort" encoder
144+ )
145+
146+
147+addStmt :: State -> JS.Stmt -> State
148+addStmt state stmt =
149+ addBuilder state (JS.stmtToBuilder stmt)
150+
151+
152+addBuilder :: State -> B.Builder -> State
153+addBuilder (State revBuilders seen) builder =
154+ State (builder:revBuilders) seen
155+
156+
157+var :: Opt.Global -> Expr.Code -> JS.Stmt
158+var (Opt.Global home name) code =
159+ JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
160+
161+
162+
163+-- GENERATE CYCLES
164+
165+
166+generateCycle :: Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
167+generateCycle mode (Opt.Global home _) cycle =
118168 let
119− state2 =
120− state1 { _seenDecls = Set.insert var (_seenDecls state1) }
121−
122− (State builders seenDecls seenKernels effects) =
123− Set.foldl' (crawl env graph) state2 direct
124−
125− stmt =
126− JS.run (JsExpr.generateDecl home name body)
127−
128− state4 =
129− State
130− { _builders = JsBuilder.stmtToBuilder stmt : builders
131− , _seenDecls = seenDecls
132− , _seenKernels = seenKernels
133− , _effects = maybe id (Map.insert home) fx effects
134− }
169+ safeDefs = map (generateSafeCycle mode home) cycle
170+ realDefs = map (generateRealCycle home) cycle
171+ -- TODO add `try` in debug mode nice infinite recursion reports
135172 in
136− Set.foldl' (crawl env graph) state4 indirect
173+ JS.Block (safeDefs ++ realDefs)
174+
137175
176+generateSafeCycle :: Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
177+generateSafeCycle mode home (name, expr) =
178+ JS.FunctionStmt (Name.fromCycle home name) [] $
179+ Expr.codeToStmtList (Expr.generate mode expr)
180+
181+
182+generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
183+generateRealCycle home (name, _) =
184+ let
185+ safeName = Name.fromCycle home name
186+ realName = Name.fromGlobal home name
187+ in
188+ JS.Block
189+ [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
190+ , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
191+ JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
192+ ]
138193
139194
140−-- CRAWL KERNEL
141195
196+-- GENERATE KERNEL
142197
143−crawlKernel :: Env -> Obj.Graph -> ModuleName.Raw -> Kernel.Data -> State -> State
144−crawlKernel env@(Env _ target) graph name (Kernel.Data client maybeServer) state =
198+
199+generateKernel :: Mode -> [Opt.KChunk] -> B.Builder
200+generateKernel mode chunks =
201+ List.foldl' (addChunk mode) mempty chunks
202+
203+
204+addChunk :: Mode -> B.Builder -> Opt.KChunk -> B.Builder
205+addChunk mode builder chunk =
206+ case chunk of
207+ Opt.JS javascript ->
208+ B.byteString javascript <> builder
209+
210+ Opt.Var home name ->
211+ Name.toBuilder (Name.fromGlobal (ModuleName.Canonical Pkg.core home) name) <> builder
212+
213+ Opt.ElmField name ->
214+ Name.toBuilder (Name.fromField mode name) <> builder
215+
216+ Opt.JsField int ->
217+ Name.toBuilder (Name.fromInt int) <> builder
218+
219+ Opt.Enum int ->
220+ Name.toBuilder (Name.fromInt int) <> builder
221+
222+ Opt.Debug ->
223+ case mode of
224+ Name.Debug _ ->
225+ builder
226+
227+ Name.Prod _ _ ->
228+ "_UNUSED" <> builder
229+
230+ Opt.Prod ->
231+ case mode of
232+ Name.Debug _ ->
233+ "_UNUSED" <> builder
234+
235+ Name.Prod _ _ ->
236+ builder
237+
238+
239+
240+-- GENERATE PORTS
241+
242+
243+generatePort :: Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
244+generatePort mode (Opt.Global home name) makePort converter =
145245 let
146− content =
147− case target of
148− Server ->
149− maybe client id maybeServer
246+ definition =
247+ JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
248+ [ JS.String (N.toBuilder name)
249+ , Expr.codeToExpr (Expr.generate mode converter)
250+ ]
251+ in
252+ JS.Var [ (Name.fromGlobal home name, Just definition) ]
253+
254+
255+
256+-- GENERATE MANAGER
257+
258+
259+
260+generateManager :: Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
261+generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
262+ let
263+ managerLVar =
264+ JS.LBracket
265+ (JS.Ref (Name.fromKernel N.platform "effectManagers"))
266+ (JS.String (N.toBuilder moduleName))
267+
268+ (deps, args, stmts) =
269+ generateManagerHelp home effectsType
150270
151− Client ->
152− client
271+ createManager =
272+ JS.ExprStmt $ JS.Assign managerLVar $
273+ JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
153274 in
154− crawlKernelContent env graph name content state
275+ addStmt (List.foldl' (addGlobal mode graph) state deps) $
276+ JS.Block (createManager : stmts)
155277
156278
157−crawlKernelContent :: Env -> Obj.Graph -> ModuleName.Raw -> Kernel.Content -> State -> State
158−crawlKernelContent env@(Env debug _) graph name (Kernel.Content imports chunks) state1 =
279+generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
280+generateLeaf home@(ModuleName.Canonical _ moduleName) name =
159281 let
160− state2 =
161− state1 { _seenKernels = Set.insert name (_seenKernels state1) }
282+ definition =
283+ JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
284+ in
285+ JS.Var [ (Name.fromGlobal home name, Just definition) ]
286+
162287
163− (State builders seenDecls seenKernels effects) =
164− List.foldl' (crawl env graph) state2 (map toCoreGlobal imports)
288+{-# NOINLINE leaf #-}
289+leaf :: JS.Expr
290+leaf =
291+ JS.Ref (Name.fromKernel N.platform "leaf")
165292
166− builder =
167− JS.run (foldM (chunkToBuilder debug) mempty chunks)
293+
294+generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
295+generateManagerHelp home effectsType =
296+ let
297+ dep name = Opt.Global home name
298+ ref name = JS.Ref (Name.fromGlobal home name)
168299 in
169− State
170− { _builders = builder : builders
171− , _seenDecls = seenDecls
172− , _seenKernels = seenKernels
173− , _effects = effects
174− }
300+ case effectsType of
301+ Opt.Cmd ->
302+ ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
303+ , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
304+ , [ generateLeaf home "command" ]
305+ )
175306
307+ Opt.Sub ->
308+ ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
309+ , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
310+ , [ generateLeaf home "subscription" ]
311+ )
176312
177−toCoreGlobal :: ( ModuleName.Raw, Text.Text ) -> Var.Global
178−toCoreGlobal (home, name) =
179− Var.Global (ModuleName.inCore home) name
313+ Opt.Fx ->
314+ ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
315+ , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
316+ , [ generateLeaf home "command"
317+ , generateLeaf home "subscription"
318+ ]
319+ )
180320
181321
182−chunkToBuilder :: Bool -> BS.Builder -> Kernel.Chunk -> JS.Generator BS.Builder
183−chunkToBuilder debug builder chunk =
184− case chunk of
185− Kernel.JS javascript ->
186− return $ BS.byteString javascript <> builder
187322
188− Kernel.Var home name ->
189− do expr <- JS.global (Var.Global (ModuleName.inCore home) name)
190− return $ JsBuilder.exprToBuilder expr <> builder
323+-- ADD MAIN
191324
192− Kernel.Field name ->
193− -- TODO generate a smaller field
194− return $ Text.encodeUtf8Builder name <> builder
195325
196− Kernel.Debug ->
197− return $ if debug then builder else "_UNUSED" <> builder
326+type Mains =
327+ Map.Map ModuleName.Canonical Opt.Main
198328
199− Kernel.Prod ->
200− return $ if debug then "_UNUSED" <> builder else builder
201329
330+generateMain :: Mode -> Graph -> Mains -> B.Builder
331+generateMain mode graph mains =
332+ mconcat
333+ [ stateToBuilder $ Map.foldrWithKey (addMain mode graph) emptyState mains
334+ , exportMains mains
335+ ]
202336
203337
204−-- CRAWL HELPERS
338+addMain :: Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
339+addMain mode graph home _ state =
340+ addGlobal mode graph state (Opt.Global home "main")
205341
206342
207−crawlError :: Var.Global -> String
208−crawlError (Var.Global (ModuleName.Canonical pkg home) name) =
209− Text.unpack $
210− "compiler bug manifesting in Generate.JavaScript\n"
211− <> "Could not find " <> Pkg.toText pkg <> " " <> ModuleName.toText home <> "." <> name <> "\n"
212− <> "Please report at <https://github.com/elm-lang/elm-compiler/issues>\n"
213− <> "Try to make an <http://sscce.org/> that demonstrates the issue!"
343+exportMains :: Mains -> B.Builder
344+exportMains mains =
345+ error "TODO" mains
214346
215347
216−virtualDomDebug :: ModuleName.Canonical
217−virtualDomDebug =
218− ModuleName.inVirtualDom "VirtualDom.Debug"
348+verifyMains :: Mains -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] Mains
349+verifyMains mains modules =
350+ let
351+ rootSet = Set.fromList modules
352+ rootMap = Map.restrictKeys mains rootSet
353+ in
354+ if Map.size rootMap == Set.size rootSet then
355+ Right rootMap
356+ else
357+ Left $ Set.toList $
358+ Set.intersection rootSet (Map.keysSet mains)