git.iko.soy/elk
on master help sign in
Get Generate.JavaScript working again
6bc0cbbEvan Czaplicki
src/Generate/JavaScript.hs+278−138
compare with master
unifiedsplit
@@ -2,217 +2,357 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript
3module Generate.JavaScript
4 ( generate
4 ( generate
5− , Target(..)
5+ , Roots(..)
6 )
6 )
7 where
7 where
8
8
9−import Control.Monad (foldM)
9+
10+import Prelude hiding (cycle)
11+import qualified Data.ByteString.Builder as B
10import Data.Monoid ((<>))
12import Data.Monoid ((<>))
11import qualified Data.List as List
13import qualified Data.List as List
14+import Data.Map ((!))
12import qualified Data.Map as Map
15import qualified Data.Map as Map
13import qualified Data.Set as Set
16import 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
17
17
18−import qualified AST.Effects as Effects
18+import qualified AST.Optimized as Opt
19−import qualified AST.Expression.Optimized as Opt
20−import qualified AST.Kernel as Kernel
21import qualified AST.Module.Name as ModuleName
19import qualified AST.Module.Name as ModuleName
22−import qualified AST.Variable as Var
20+import qualified Elm.Name as N
23import qualified Elm.Package as Pkg
21import qualified Elm.Package as Pkg
24−import qualified Elm.Compiler.Objects.Internal as Obj
25−import qualified Generate.JavaScript.Builder as JsBuilder
22+import qualified Generate.JavaScript.Builder as JS
26−import qualified Generate.JavaScript.Effects as JsEffects
27−import qualified Generate.JavaScript.Expression as JsExpr
23+import qualified Generate.JavaScript.Expression as Expr
28−import qualified Generate.JavaScript.Variable as JS
24+import qualified Generate.JavaScript.Name as Name
29
25
30
26
31
27
32−-- GENERATE JAVASCRIPT
28+-- GENERATE
33
29
34
30
35−generate :: Bool -> Target -> Obj.Graph -> Obj.Roots -> BS.Builder
31+data Roots
36−generate debug target graph roots =
32+ = Mains [ModuleName.Canonical]
37− let
33+ | Value ModuleName.Canonical N.Name
38− (State builders _ _ effects) =
39− List.foldl' (crawl (Env debug target) graph) initialState (Obj.toGlobals roots)
40
34
41− managers =
42− JS.run (JsEffects.generate effects)
43− in
44− List.foldl' (\rest stmt -> stmt <> rest) managers builders
45
35
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)
46
42
43+ Mains modules ->
44+ generateMain (toMode debug target fields) nodes
45+ <$> verifyMains mains modules
47
46
48−-- CRAWL ENV
49
47
50−
48+toMode :: Bool -> Name.Target -> Map.Map N.Name Int -> Name.Mode
51−data Env =
49+toMode debug target fields =
52− Env
50+ if debug then
53− { _debug :: Bool
51+ Name.Debug target
54− , _target :: Target
52+ else
55− }
53+ Name.Prod target (Name.shortenFieldNames fields)
56−
57−
58−data Target = Client | Server
59
54
60
55
61
56
62−-- CRAWL STATE
57+-- GRAPH TRAVERSAL STATE
63
58
64
59
65data State =
60data State =
66 State
61 State
67− { _builders :: [BS.Builder]
62+ { _revBuilders :: [B.Builder]
68− , _seenDecls :: Set.Set Var.Global
63+ , _seenGlobals :: Set.Set Opt.Global
69− , _seenKernels :: Set.Set ModuleName.Raw
70− , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
71 }
64 }
72
65
73
66
74−initialState :: State
67+emptyState :: State
75−initialState =
68+emptyState =
76− State [] Set.empty Set.empty Map.empty
69+ State [] Set.empty
77
70
78
71
72+stateToBuilder :: State -> B.Builder
73+stateToBuilder (State revBuilders _) =
74+ List.foldl1' (\builder b -> b <> builder) revBuilders
79
75
80−-- CRAWL
81
76
82
77
83−crawl :: Env -> Obj.Graph -> State -> Var.Global -> State
78+-- ADD DEPENDENCIES
84−crawl env graph@(Obj.Graph decls kernels) state@(State _ seenDecls seenKernels _) name@(Var.Global home _) =
79+
85− if Set.member name seenDecls then
80+
86− state
81+type Mode = Name.Mode
82+type Graph = Map.Map Opt.Global Opt.Node
87
83
88− else if home == virtualDomDebug then
89− state
90
84
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
91 else
89 else
92− case Map.lookup name decls of
90+ addGlobalHelp mode graph global $
93− Just decl ->
91+ State builders (Set.insert global seen)
94− crawlDecl env graph name decl state
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+ )
95
110
96− Nothing ->
111+ Opt.Ctor name index arity ->
97− let
112+ let (args, ctor) = Expr.generateCtor mode name index arity in
98− kernelModule =
99− ModuleName._module home
100− in
101− if Set.member kernelModule seenKernels then
102− state
113+ addStmt state (
103− else
114+ var global (Expr.generateFunction args ctor)
104− case Map.lookup kernelModule kernels of
115+ )
105− Just info ->
106− crawlKernel env graph kernelModule info state
107
116
108− Nothing ->
117+ Opt.Link linkedGlobal ->
109− error (crawlError name)
118+ addGlobal mode graph state linkedGlobal
110
119
120+ Opt.Cycle cycle deps ->
121+ addStmt (addDeps deps state) (
122+ generateCycle mode global cycle
123+ )
111
124
125+ Opt.Manager effectsType ->
126+ generateManager mode graph global effectsType state
112
127
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)
114
132
133+ _ ->
134+ addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
115
135
116−crawlDecl :: Env -> Obj.Graph -> Var.Global -> Opt.Decl -> State -> State
136+ Opt.PortIncoming decoder deps ->
117−crawlDecl env graph var@(Var.Global home name) (Opt.Decl direct indirect fx body) state1 =
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 =
118 let
168 let
119− state2 =
169+ safeDefs = map (generateSafeCycle mode home) cycle
120− state1 { _seenDecls = Set.insert var (_seenDecls state1) }
170+ realDefs = map (generateRealCycle home) cycle
121−
171+ -- TODO add `try` in debug mode nice infinite recursion reports
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− }
135 in
172 in
136− Set.foldl' (crawl env graph) state4 indirect
173+ JS.Block (safeDefs ++ realDefs)
174+
137
175
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+ ]
138
193
139
194
140−-- CRAWL KERNEL
141
195
196+-- GENERATE KERNEL
142
197
143−crawlKernel :: Env -> Obj.Graph -> ModuleName.Raw -> Kernel.Data -> State -> State
198+
144−crawlKernel env@(Env _ target) graph name (Kernel.Data client maybeServer) state =
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 =
145 let
245 let
146− content =
246+ definition =
147− case target of
247+ JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
148− Server ->
248+ [ JS.String (N.toBuilder name)
149− maybe client id maybeServer
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
150
270
151− Client ->
271+ createManager =
152− client
272+ JS.ExprStmt $ JS.Assign managerLVar $
273+ JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
153 in
274 in
154− crawlKernelContent env graph name content state
275+ addStmt (List.foldl' (addGlobal mode graph) state deps) $
276+ JS.Block (createManager : stmts)
155
277
156
278
157−crawlKernelContent :: Env -> Obj.Graph -> ModuleName.Raw -> Kernel.Content -> State -> State
279+generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
158−crawlKernelContent env@(Env debug _) graph name (Kernel.Content imports chunks) state1 =
280+generateLeaf home@(ModuleName.Canonical _ moduleName) name =
159 let
281 let
160− state2 =
282+ definition =
161− state1 { _seenKernels = Set.insert name (_seenKernels state1) }
283+ JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
284+ in
285+ JS.Var [ (Name.fromGlobal home name, Just definition) ]
286+
162
287
163− (State builders seenDecls seenKernels effects) =
288+{-# NOINLINE leaf #-}
164− List.foldl' (crawl env graph) state2 (map toCoreGlobal imports)
289+leaf :: JS.Expr
290+leaf =
291+ JS.Ref (Name.fromKernel N.platform "leaf")
165
292
166− builder =
293+
167− JS.run (foldM (chunkToBuilder debug) mempty chunks)
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)
168 in
299 in
169− State
300+ case effectsType of
170− { _builders = builder : builders
301+ Opt.Cmd ->
171− , _seenDecls = seenDecls
302+ ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
172− , _seenKernels = seenKernels
303+ , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
173− , _effects = effects
304+ , [ generateLeaf home "command" ]
174− }
305+ )
175
306
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+ )
176
312
177−toCoreGlobal :: ( ModuleName.Raw, Text.Text ) -> Var.Global
313+ Opt.Fx ->
178−toCoreGlobal (home, name) =
314+ ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
179− Var.Global (ModuleName.inCore home) name
315+ , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
316+ , [ generateLeaf home "command"
317+ , generateLeaf home "subscription"
318+ ]
319+ )
180
320
181
321
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
187
322
188− Kernel.Var home name ->
323+-- ADD MAIN
189− do expr <- JS.global (Var.Global (ModuleName.inCore home) name)
190− return $ JsBuilder.exprToBuilder expr <> builder
191
324
192− Kernel.Field name ->
193− -- TODO generate a smaller field
194− return $ Text.encodeUtf8Builder name <> builder
195
325
196− Kernel.Debug ->
326+type Mains =
197− return $ if debug then builder else "_UNUSED" <> builder
327+ Map.Map ModuleName.Canonical Opt.Main
198
328
199− Kernel.Prod ->
200− return $ if debug then "_UNUSED" <> builder else builder
201
329
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+ ]
202
336
203
337
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")
205
341
206
342
207−crawlError :: Var.Global -> String
343+exportMains :: Mains -> B.Builder
208−crawlError (Var.Global (ModuleName.Canonical pkg home) name) =
344+exportMains mains =
209− Text.unpack $
345+ error "TODO" mains
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!"
214
346
215
347
216−virtualDomDebug :: ModuleName.Canonical
348+verifyMains :: Mains -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] Mains
217−virtualDomDebug =
349+verifyMains mains modules =
218− ModuleName.inVirtualDom "VirtualDom.Debug"
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)
src/Generate/JavaScript/Builder.hs+2−10
@@ -46,7 +46,7 @@ data Expr
46
46
47
47
48data LValue
48data LValue
49− = LVar Name
49+ = LRef Name
50 | LDot Expr Name
50 | LDot Expr Name
51 | LBracket Expr Expr
51 | LBracket Expr Expr
52
52
@@ -62,7 +62,6 @@ data Stmt
62 | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
62 | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
63 | Switch Expr [Case] -- switch (e) clauses
63 | Switch Expr [Case] -- switch (e) clauses
64 | While Expr Stmt -- while (e) do stmt
64 | While Expr Stmt -- while (e) do stmt
65− | DoWhile Stmt Expr -- do stmt while (e);
66 | Break (Maybe Name) -- break lab;
65 | Break (Maybe Name) -- break lab;
67 | Continue (Maybe Name) -- continue lab;
66 | Continue (Maybe Name) -- continue lab;
68 | Labelled Name Stmt -- lab: stmt
67 | Labelled Name Stmt -- lab: stmt
@@ -191,13 +190,6 @@ fromStmt indent statement =
191 , indent, "}\n"
190 , indent, "}\n"
192 ]
191 ]
193
192
194− DoWhile stmt expr ->
195− mconcat
196− [ indent, "do {\n"
197− , fromStmt (deeper indent) stmt
198− , indent, "} while(", snd (fromExpr indent Whatever expr), ");\n"
199− ]
200−
201 Break Nothing ->
193 Break Nothing ->
202 indent <> "break;\n"
194 indent <> "break;\n"
203
195
@@ -454,7 +446,7 @@ fromField indent (field, expr) =
454fromLValue :: Builder -> LValue -> (Lines, Builder)
446fromLValue :: Builder -> LValue -> (Lines, Builder)
455fromLValue indent lValue =
447fromLValue indent lValue =
456 case lValue of
448 case lValue of
457− LVar name ->
449+ LRef name ->
458 (One, Name.toBuilder name)
450 (One, Name.toBuilder name)
459
451
460 LDot expr field ->
452 LDot expr field ->
src/Generate/JavaScript/BuiltIn.hsdeleted−160
@@ -1,160 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Generate.JavaScript.BuiltIn
4− ( char
5− , list
6− , cons
7− , recordUpdate
8− , eq
9− , cmp
10− , effectManagers
11− , effect
12− , outgoingPort
13− , incomingPort
14− , staticProgram
15− , crash
16− )
17− where
18−
19−
20−import Data.Text (Text)
21−
22−import qualified AST.Module.Name as ModuleName
23−import qualified AST.Variable as Var
24−import qualified Generate.JavaScript.Builder as JS
25−import Generate.JavaScript.Helpers ((<|), (==>))
26−import qualified Generate.JavaScript.Variable as Var
27−import Generate.JavaScript.Variable (Generator)
28−import qualified Reporting.Region as R
29−
30−
31−
32−-- LITERALS
33−
34−
35−char :: Text -> Generator JS.Expr
36−char c =
37− utils "chr" [ JS.String c ]
38−
39−
40−utils :: Text -> [JS.Expr] -> Generator JS.Expr
41−utils name args =
42− do func <- core "Elm.Kernel.Utils" name
43− return $ JS.Call func args
44−
45−
46−core :: ModuleName.Raw -> Text -> Generator JS.Expr
47−core home name =
48− Var.global (Var.Global (ModuleName.inCore home) name)
49−
50−
51−
52−-- LISTS
53−
54−
55−list :: [JS.Expr] -> Generator JS.Expr
56−list elements =
57− do fromArray <- core "Elm.Kernel.List" "fromArray"
58− return $ fromArray <| JS.Array elements
59−
60−
61−cons :: JS.Expr -> JS.Expr -> Generator JS.Expr
62−cons first rest =
63− do func <- core "Elm.Kernel.List" "Cons"
64− return $ JS.Call func [first, rest]
65−
66−
67−
68−-- RECORDS
69−
70−
71−recordUpdate :: JS.Expr -> [(Text, JS.Expr)] -> Generator JS.Expr
72−recordUpdate record fields =
73− utils "update"
74− [ record
75− , JS.Object (map (uncurry (==>)) fields)
76− ]
77−
78−
79−
80−-- COMPARISIONS
81−
82−
83−eq :: JS.Expr -> JS.Expr -> Generator JS.Expr
84−eq left right =
85− utils "eq" [ left, right ]
86−
87−
88−cmp :: JS.Expr -> JS.Expr -> Generator JS.Expr
89−cmp left right =
90− utils "cmp" [ left, right ]
91−
92−
93−
94−-- EFFECTS
95−
96−
97−effectManagers :: Generator JS.Expr
98−effectManagers =
99− core "Elm.Kernel.Platform" "effectManagers"
100−
101−
102−effect :: ModuleName.Canonical -> Generator JS.Expr
103−effect effectName =
104− do leaf <- core "Elm.Kernel.Platform" "leaf"
105− return $ leaf <| JS.String (ModuleName.canonicalToText effectName)
106−
107−
108−outgoingPort :: Text -> JS.Expr -> Generator JS.Expr
109−outgoingPort name converter =
110− do outPort <- core "Elm.Kernel.Platform" "outgoingPort"
111− return $ JS.Call outPort [ JS.String name, converter ]
112−
113−
114−incomingPort :: Text -> JS.Expr -> Generator JS.Expr
115−incomingPort name converter =
116− do inPort <- core "Elm.Kernel.Platform" "incomingPort"
117− return $ JS.Call inPort [ JS.String name, converter ]
118−
119−
120−
121−-- VIRTUAL DOM
122−
123−
124−staticProgram :: Generator JS.Expr
125−staticProgram =
126− Var.global (Var.Global (ModuleName.inBrowser "Browser") "staticPage")
127−
128−
129−
130−-- CRASH
131−
132−
133−crash :: ModuleName.Canonical -> R.Region -> Maybe (JS.Expr) -> Generator JS.Expr
134−crash home region maybeCaseCrashValue =
135− let
136− homeString =
137− JS.String (ModuleName.canonicalToText home)
138− in
139− case maybeCaseCrashValue of
140− Nothing ->
141− utils "crash" [ homeString, regionToJs region ]
142−
143− Just crashValue ->
144− utils "crashCase" [ homeString, regionToJs region, crashValue ]
145−
146−
147−regionToJs :: R.Region -> JS.Expr
148−regionToJs (R.Region start end) =
149− JS.Object
150− [ "start" ==> positionToJs start
151− , "end" ==> positionToJs end
152− ]
153−
154−
155−positionToJs :: R.Position -> JS.Expr
156−positionToJs (R.Position line column) =
157− JS.Object
158− [ "line" ==> JS.Int line
159− , "column" ==> JS.Int column
160− ]
src/Generate/JavaScript/Effects.hsdeleted−69
@@ -1,69 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Generate.JavaScript.Effects
4− ( generate
5− )
6− where
7−
8−
9−import qualified Data.ByteString.Builder as BS
10−import qualified Data.Map as Map
11−import Data.Monoid ((<>))
12−
13−import qualified AST.Effects as Effects
14−import qualified AST.Module.Name as ModuleName
15−import qualified AST.Variable as Var
16−import qualified Generate.JavaScript.Builder as JS
17−import qualified Generate.JavaScript.BuiltIn as BuiltIn
18−import qualified Generate.JavaScript.Variable as Var
19−
20−
21−
22−-- GENERATE
23−
24−
25−generate :: Map.Map ModuleName.Canonical Effects.ManagerType -> Var.Generator BS.Builder
26−generate managers =
27− let
28− add home mngr makeBuilder =
29− do builder <- makeBuilder
30− stmt <- generateManager home mngr
31− return (JS.stmtToBuilder stmt <> builder)
32− in
33− Map.foldrWithKey' add (return "") managers
34−
35−
36−generateManager :: ModuleName.Canonical -> Effects.ManagerType -> Var.Generator JS.Stmt
37−generateManager home manager =
38− do managers <- BuiltIn.effectManagers
39− let managerName = JS.String (ModuleName.canonicalToText home)
40− let lValue = JS.LBracket managers managerName
41− entries <- generateEntries home manager
42− return $ JS.ExprStmt (JS.Assign lValue entries)
43−
44−
45−generateEntries :: ModuleName.Canonical -> Effects.ManagerType -> Var.Generator JS.Expr
46−generateEntries home manager =
47− let
48− arg name =
49− Var.global (Var.Global home name)
50−
51− makeArgs =
52− case manager of
53− Effects.Cmds ->
54− [ arg "init", arg "onEffects", arg "onSelfMsg", arg "cmdMap" ]
55−
56− Effects.Subs ->
57− [ arg "init", arg "onEffects", arg "onSelfMsg", pure (JS.Int 0), arg "subMap" ]
58−
59− Effects.Both ->
60− [ arg "init", arg "onEffects", arg "onSelfMsg", arg "cmdMap", arg "subMap" ]
61− in
62− JS.Call
63− <$> Var.global createManager
64− <*> sequence makeArgs
65−
66−
67−createManager :: Var.Global
68−createManager =
69− Var.Global (ModuleName.inCore "Elm.Kernel.Platform") "createManager"
src/Generate/JavaScript/Expression.hs+60−34
@@ -1,6 +1,11 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript.Expression
2module Generate.JavaScript.Expression
3− ( generateJsExpr
3+ ( generate
4+ , generateCtor
5+ , generateFunction
6+ , Code
7+ , codeToExpr
8+ , codeToStmtList
4 )
9 )
5 where
10 where
6
11
@@ -34,19 +39,19 @@ type Mode = Name.Mode
34
39
35generateJsExpr :: Mode -> Opt.Expr -> JS.Expr
40generateJsExpr :: Mode -> Opt.Expr -> JS.Expr
36generateJsExpr mode expression =
41generateJsExpr mode expression =
37− codeToJsExpr (generateCode mode expression)
42+ codeToExpr (generate mode expression)
38
43
39
44
40−generateCode :: Mode -> Opt.Expr -> Code
45+generate :: Mode -> Opt.Expr -> Code
41−generateCode mode expression =
46+generate mode expression =
42 case expression of
47 case expression of
43 Opt.Chr char ->
48 Opt.Chr char ->
44 JsExpr $
49 JsExpr $
45 case mode of
50 case mode of
46− Name.Debug ->
51+ Name.Debug _ ->
47 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
52 JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]
48
53
49− Name.Prod _ ->
54+ Name.Prod _ _ ->
50 JS.String (Text.encodeUtf8Builder char)
55 JS.String (Text.encodeUtf8Builder char)
51
56
52 Opt.Str string ->
57 Opt.Str string ->
@@ -65,7 +70,7 @@ generateCode mode expression =
65 JsExpr $ JS.Ref (Name.fromGlobal home name)
70 JsExpr $ JS.Ref (Name.fromGlobal home name)
66
71
67 Opt.VarCycle home name ->
72 Opt.VarCycle home name ->
68− JsExpr $ JS.Ref (Name.fromCycle home name)
73+ JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []
69
74
70 Opt.VarDebug name home region unhandledValueName ->
75 Opt.VarDebug name home region unhandledValueName ->
71 JsExpr $ generateDebug name home region unhandledValueName
76 JsExpr $ generateDebug name home region unhandledValueName
@@ -81,7 +86,7 @@ generateCode mode expression =
81 ]
86 ]
82
87
83 Opt.Function args body ->
88 Opt.Function args body ->
84− generateFunction args (generateCode mode body)
89+ generateFunction (map Name.fromLocal args) (generate mode body)
85
90
86 Opt.Call func args ->
91 Opt.Call func args ->
87 JsExpr $ generateCall mode func args
92 JsExpr $ generateCall mode func args
@@ -94,7 +99,7 @@ generateCode mode expression =
94
99
95 Opt.Let def body ->
100 Opt.Let def body ->
96 JsBlock $
101 JsBlock $
97− generateDef mode def : codeToStatementList (generateCode mode body)
102+ generateDef mode def : codeToStmtList (generate mode body)
98
103
99 Opt.Case label root decider jumps ->
104 Opt.Case label root decider jumps ->
100 JsBlock $ generateCase mode label root decider jumps
105 JsBlock $ generateCase mode label root decider jumps
@@ -154,8 +159,8 @@ data Code
154 | JsBlock [JS.Stmt]
159 | JsBlock [JS.Stmt]
155
160
156
161
157−codeToJsExpr :: Code -> JS.Expr
162+codeToExpr :: Code -> JS.Expr
158−codeToJsExpr code =
163+codeToExpr code =
159 case code of
164 case code of
160 JsExpr expr ->
165 JsExpr expr ->
161 expr
166 expr
@@ -164,8 +169,8 @@ codeToJsExpr code =
164 JS.Call (JS.Function Nothing [] stmts) []
169 JS.Call (JS.Function Nothing [] stmts) []
165
170
166
171
167−codeToStatementList :: Code -> [JS.Stmt]
172+codeToStmtList :: Code -> [JS.Stmt]
168−codeToStatementList code =
173+codeToStmtList code =
169 case code of
174 case code of
170 JsExpr expr ->
175 JsExpr expr ->
171 [ JS.Return (Just expr) ]
176 [ JS.Return (Just expr) ]
@@ -174,8 +179,8 @@ codeToStatementList code =
174 stmts
179 stmts
175
180
176
181
177−codeToStatement :: Code -> JS.Stmt
182+codeToStmt :: Code -> JS.Stmt
178−codeToStatement code =
183+codeToStmt code =
179 case code of
184 case code of
180 JsExpr expr ->
185 JsExpr expr ->
181 JS.Return (Just expr)
186 JS.Return (Just expr)
@@ -198,6 +203,27 @@ toChar =
198
203
199
204
200
205
206+-- CTOR
207+
208+
209+generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> ([Name.Name], Code)
210+generateCtor mode name index arity =
211+ let
212+ argNames = map Name.fromInt [1 .. arity]
213+ argFields = map (\n -> (n, JS.Ref n)) argNames
214+
215+ tag =
216+ case mode of
217+ Name.Debug _ ->
218+ ( Name.dollar, JS.String (N.toBuilder name) )
219+
220+ Name.Prod _ _ ->
221+ ( Name.dollar, JS.Int (Index.toZeroBased index) )
222+ in
223+ ( argNames, JsExpr (JS.Object (tag:argFields)) )
224+
225+
226+
201-- RECORDS
227-- RECORDS
202
228
203
229
@@ -254,21 +280,21 @@ positionToJsExpr (R.Position line column) =
254-- FUNCTION
280-- FUNCTION
255
281
256
282
257−generateFunction :: [N.Name] -> Code -> Code
283+generateFunction :: [Name.Name] -> Code -> Code
258generateFunction args body =
284generateFunction args body =
259 case IntMap.lookup (length args) funcHelpers of
285 case IntMap.lookup (length args) funcHelpers of
260 Just helper ->
286 Just helper ->
261 JsExpr $
287 JsExpr $
262 JS.Call helper
288 JS.Call helper
263− [ JS.Function Nothing (map Name.fromLocal args) $
289+ [ JS.Function Nothing args $
264− codeToStatementList body
290+ codeToStmtList body
265 ]
291 ]
266
292
267 Nothing ->
293 Nothing ->
268 let
294 let
269 addArg arg code =
295 addArg arg code =
270− JsExpr $ JS.Function Nothing [Name.fromLocal arg] $
296+ JsExpr $ JS.Function Nothing [arg] $
271− codeToStatementList code
297+ codeToStmtList code
272 in
298 in
273 foldr addArg body args
299 foldr addArg body args
274
300
@@ -610,7 +636,7 @@ generateTailCall mode name args =
610
636
611 toRealVars (argName, _) =
637 toRealVars (argName, _) =
612 JS.ExprStmt $
638 JS.ExprStmt $
613− JS.Assign (JS.LVar (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
639+ JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))
614 in
640 in
615 JS.Var (map toTempVars args)
641 JS.Var (map toTempVars args)
616 : map toRealVars args
642 : map toRealVars args
@@ -633,7 +659,7 @@ generateDef mode def =
633 JS.Function Nothing (map Name.fromLocal argNames)
659 JS.Function Nothing (map Name.fromLocal argNames)
634 [ JS.Labelled (Name.fromLocal name) $
660 [ JS.Labelled (Name.fromLocal name) $
635 JS.While (JS.Bool True) $
661 JS.While (JS.Bool True) $
636− codeToStatement $ generateCode mode body
662+ codeToStmt $ generate mode body
637 ]
663 ]
638 in
664 in
639 JS.Var [ (Name.fromLocal name, Just function) ]
665 JS.Var [ (Name.fromLocal name, Just function) ]
@@ -651,26 +677,26 @@ generateIf mode givenBranches givenFinal =
651
677
652 convertBranch (condition, expr) =
678 convertBranch (condition, expr) =
653 ( generateJsExpr mode condition
679 ( generateJsExpr mode condition
654− , generateCode mode expr
680+ , generate mode expr
655 )
681 )
656
682
657 branchExprs = map convertBranch branches
683 branchExprs = map convertBranch branches
658− finalCode = generateCode mode final
684+ finalCode = generate mode final
659 in
685 in
660 if isBlock finalCode || any (isBlock . snd) branchExprs then
686 if isBlock finalCode || any (isBlock . snd) branchExprs then
661− JsBlock [ foldr addStmtIf (codeToStatement finalCode) branchExprs ]
687+ JsBlock [ foldr addStmtIf (codeToStmt finalCode) branchExprs ]
662 else
688 else
663− JsExpr $ foldr addExprIf (codeToJsExpr finalCode) branchExprs
689+ JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs
664
690
665
691
666addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
692addExprIf :: (JS.Expr, Code) -> JS.Expr -> JS.Expr
667addExprIf (condition, branch) final =
693addExprIf (condition, branch) final =
668− JS.If condition (codeToJsExpr branch) final
694+ JS.If condition (codeToExpr branch) final
669
695
670
696
671addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
697addStmtIf :: (JS.Expr, Code) -> JS.Stmt -> JS.Stmt
672addStmtIf (condition, branch) final =
698addStmtIf (condition, branch) final =
673− JS.IfStmt condition (codeToStatement branch) final
699+ JS.IfStmt condition (codeToStmt branch) final
674
700
675
701
676isBlock :: Code -> Bool
702isBlock :: Code -> Bool
@@ -721,14 +747,14 @@ goto mode label (index, branch) stmts =
721 (Name.makeLabel label index)
747 (Name.makeLabel label index)
722 (JS.While (JS.Bool True) (JS.Block stmts))
748 (JS.While (JS.Bool True) (JS.Block stmts))
723 in
749 in
724− labeledDeciderStmt : codeToStatementList (generateCode mode branch)
750+ labeledDeciderStmt : codeToStmtList (generate mode branch)
725
751
726
752
727generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
753generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]
728generateDecider mode label root decisionTree =
754generateDecider mode label root decisionTree =
729 case decisionTree of
755 case decisionTree of
730 Opt.Leaf (Opt.Inline branch) ->
756 Opt.Leaf (Opt.Inline branch) ->
731− codeToStatementList (generateCode mode branch)
757+ codeToStmtList (generate mode branch)
732
758
733 Opt.Leaf (Opt.Jump index) ->
759 Opt.Leaf (Opt.Jump index) ->
734 [ JS.Break (Just (Name.makeLabel label index)) ]
760 [ JS.Break (Just (Name.makeLabel label index)) ]
@@ -768,10 +794,10 @@ testToExpr mode test =
768 case test of
794 case test of
769 DT.IsCtor _ tag index ->
795 DT.IsCtor _ tag index ->
770 case mode of
796 case mode of
771− Name.Debug ->
797+ Name.Debug _ ->
772 JS.String (N.toBuilder tag)
798 JS.String (N.toBuilder tag)
773
799
774− Name.Prod _ ->
800+ Name.Prod _ _ ->
775 JS.Int (Index.toZeroBased index)
801 JS.Int (Index.toZeroBased index)
776
802
777 DT.IsInt int ->
803 DT.IsInt int ->
@@ -802,10 +828,10 @@ pathToTestableExpr mode root path exampleTest =
802
828
803 DT.IsChr _ ->
829 DT.IsChr _ ->
804 case mode of
830 case mode of
805− Name.Debug ->
831+ Name.Debug _ ->
806 JS.Call (JS.Access expr (Name.fromLocal "valueOf")) []
832 JS.Call (JS.Access expr (Name.fromLocal "valueOf")) []
807
833
808− Name.Prod _ ->
834+ Name.Prod _ _ ->
809 expr
835 expr
810
836
811
837