git.iko.soy/elk
on 7aaee62 help sign in
elk/compiler/src/Generate/JavaScript.hs
520 lines 14 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript
3 ( Output(..)
4 , generate
5 , generateForRepl
6 )
7 where
10import Prelude hiding (cycle, print)
11import qualified Data.ByteString.Builder as B
12import Data.Monoid ((<>))
13import qualified Data.List as List
14import Data.Map ((!))
15import qualified Data.Map as Map
16import qualified Data.Set as Set
17import qualified Data.Text as Text
18import qualified Data.Text.Encoding as Text
20import qualified AST.Canonical as Can
21import qualified AST.Optimized as Opt
22import qualified AST.Module.Name as ModuleName
23import qualified Data.Index as Index
24import qualified Elm.Compiler.Type as Type
25import qualified Elm.Compiler.Type.Extract as Extract
26import qualified Elm.Interface as I
27import qualified Elm.Name as N
28import qualified Generate.JavaScript.Builder as JS
29import qualified Generate.JavaScript.Expression as Expr
30import qualified Generate.JavaScript.Name as Name
31import qualified Generate.JavaScript.Mode as Mode
32import qualified Reporting.Doc as D
36-- GENERATE MAINS
39data Output
40 = None
41 | Some N.Name [N.Name] B.Builder
44generate :: Mode.Mode -> Opt.Graph -> [ModuleName.Canonical] -> Output
45generate mode (Opt.Graph mains graph _fields) roots =
46 let
47 rootSet = Set.fromList roots
48 rootMap = Map.restrictKeys mains rootSet
49 in
50 case map ModuleName._module (Map.keys rootMap) of
51 [] ->
52 None
54 name:names ->
55 let
56 state = Map.foldrWithKey (addMain mode graph) emptyState rootMap
57 builder = stateToBuilder state <> toMainExports mode rootMap
58 in
59 Some name names builder
62addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
63addMain mode graph home _ state =
64 addGlobal mode graph state (Opt.Global home "main")
68-- GENERATE FOR REPL
71generateForRepl :: Opt.Graph -> I.Interface -> ModuleName.Canonical -> N.Name -> B.Builder
72generateForRepl (Opt.Graph _ graph _) iface home name =
73 let
74 mode = Mode.dev Mode.Server
75 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
76 evalState = addGlobal mode graph debugState (Opt.Global home name)
77 in
78 stateToBuilder evalState <> print home name (I._types iface ! name)
81print :: ModuleName.Canonical -> N.Name -> Can.Annotation -> B.Builder
82print home name annotation =
83 let
84 value = Name.toBuilder (Name.fromGlobal home name)
85 toString = Name.toBuilder (Name.fromKernel N.debug "toString")
86 tipe = Type.toDoc Type.None (Extract.fromAnnotation annotation)
87 in
88 "var _value = " <> toString <> "(" <> value <> ");\n" <>
89 "var _type = " <> B.stringUtf8 (show (D.toString tipe)) <> ";\n\
90 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
91 \ console.log(_value + '\\n : ' + _type.split('\\n').join('\\n '));\n\
92 \} else {\n\
93 \ console.log(_value + ' : ' + _type);\n\
94 \}\n"
98-- GRAPH TRAVERSAL STATE
101data State =
102 State
103 { _revBuilders :: [B.Builder]
104 , _seenGlobals :: Set.Set Opt.Global
105 }
108emptyState :: State
109emptyState =
110 State [] Set.empty
113stateToBuilder :: State -> B.Builder
114stateToBuilder (State revBuilders _) =
115 List.foldl1' (\builder b -> b <> builder) revBuilders
119-- ADD DEPENDENCIES
122type Graph = Map.Map Opt.Global Opt.Node
125addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
126addGlobal mode graph state@(State builders seen) global =
127 if Set.member global seen then
128 state
129 else
130 addGlobalHelp mode graph global $
131 State builders (Set.insert global seen)
134addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
135addGlobalHelp mode graph global state =
136 let
137 addDeps deps someState =
138 Set.foldl' (addGlobal mode graph) someState deps
139 in
140 case graph ! global of
141 Opt.Define expr deps ->
142 addStmt (addDeps deps state) (
143 var global (Expr.generate mode expr)
144 )
146 Opt.DefineTailFunc argNames body deps ->
147 addStmt (addDeps deps state) (
148 let (Opt.Global _ name) = global in
149 var global (Expr.generateTailDef mode name argNames body)
150 )
152 Opt.Ctor name index arity ->
153 addStmt state (
154 var global (Expr.generateCtor mode name index arity)
155 )
157 Opt.Link linkedGlobal ->
158 addGlobal mode graph state linkedGlobal
160 Opt.Cycle cycle deps ->
161 addStmt (addDeps deps state) (
162 generateCycle mode global cycle
163 )
165 Opt.Manager effectsType ->
166 generateManager mode graph global effectsType state
168 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
169 case maybeServer of
170 Just (Opt.KContent serverChunks serverDeps) | Mode.isServer mode ->
171 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
173 _ ->
174 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
176 Opt.Enum name index ->
177 addStmt state (
178 generateEnum mode global name index
179 )
181 Opt.Box name ->
182 addStmt state (
183 generateBox mode global name
184 )
186 Opt.PortIncoming decoder deps ->
187 addStmt (addDeps deps state) (
188 generatePort mode global "incomingPort" decoder
189 )
191 Opt.PortOutgoing encoder deps ->
192 addStmt (addDeps deps state) (
193 generatePort mode global "outgoingPort" encoder
194 )
197addStmt :: State -> JS.Stmt -> State
198addStmt state stmt =
199 addBuilder state (JS.stmtToBuilder stmt)
202addBuilder :: State -> B.Builder -> State
203addBuilder (State revBuilders seen) builder =
204 State (builder:revBuilders) seen
207var :: Opt.Global -> Expr.Code -> JS.Stmt
208var (Opt.Global home name) code =
209 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
213-- GENERATE CYCLES
216generateCycle :: Mode.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
217generateCycle mode (Opt.Global home _) cycle =
218 let
219 safeDefs = map (generateSafeCycle mode home) cycle
220 realDefs = map (generateRealCycle home) cycle
221 block = JS.Block (safeDefs ++ realDefs)
222 in
223 case mode of
224 Mode.Prod _ _ ->
225 block
227 Mode.Dev _ _ ->
228 JS.Try block Name.dollar $ JS.Throw $ JS.String $
229 "The following top-level definitions are causing infinite recursion:\\n"
230 <> drawCycle (map fst cycle)
231 <> "\\n\\nThese errors are very tricky, so read "
232 <> B.stringUtf8 (D.makeLink "halting-problem")
233 <> " to learn how to fix it!"
236generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
237generateSafeCycle mode home (name, expr) =
238 JS.FunctionStmt (Name.fromCycle home name) [] $
239 Expr.codeToStmtList (Expr.generate mode expr)
242generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
243generateRealCycle home (name, _) =
244 let
245 safeName = Name.fromCycle home name
246 realName = Name.fromGlobal home name
247 in
248 JS.Block
249 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
250 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
251 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
252 ]
255drawCycle :: [N.Name] -> B.Builder
256drawCycle names =
257 let
258 topLine = "\\n ┌─────┐"
259 nameLine name = "\\n │ " <> N.toBuilder name
260 midLine = "\\n │ ↓"
261 bottomLine = "\\n └─────┘"
262 in
263 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
268-- GENERATE KERNEL
271generateKernel :: Mode.Mode -> [Opt.KChunk] -> B.Builder
272generateKernel mode chunks =
273 List.foldl' (addChunk mode) mempty chunks
276addChunk :: Mode.Mode -> B.Builder -> Opt.KChunk -> B.Builder
277addChunk mode builder chunk =
278 case chunk of
279 Opt.JS javascript ->
280 B.byteString javascript <> builder
282 Opt.ElmVar home name ->
283 Name.toBuilder (Name.fromGlobal home name) <> builder
285 Opt.JsVar home name ->
286 Name.toBuilder (Name.fromKernel home name) <> builder
288 Opt.ElmField name ->
289 Name.toBuilder (Expr.generateField mode name) <> builder
291 Opt.JsField int ->
292 Name.toBuilder (Name.fromInt int) <> builder
294 Opt.JsEnum int ->
295 B.intDec int <> builder
297 Opt.Debug ->
298 case mode of
299 Mode.Dev _ _ ->
300 builder
302 Mode.Prod _ _ ->
303 "_UNUSED" <> builder
305 Opt.Prod ->
306 case mode of
307 Mode.Dev _ _ ->
308 "_UNUSED" <> builder
310 Mode.Prod _ _ ->
311 builder
315-- GENERATE ENUM
318generateEnum :: Mode.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
319generateEnum mode (Opt.Global home name) ctorName index =
320 let
321 definition =
322 case mode of
323 Mode.Dev _ _ ->
324 Expr.codeToExpr (Expr.generateCtor mode ctorName index 0)
326 Mode.Prod _ _ ->
327 JS.Int (Index.toMachine index)
328 in
329 JS.Var [ (Name.fromGlobal home name, Just definition) ]
333-- GENERATE BOX
336generateBox :: Mode.Mode -> Opt.Global -> N.Name -> JS.Stmt
337generateBox mode (Opt.Global home name) ctorName =
338 let
339 definition =
340 case mode of
341 Mode.Dev _ _ ->
342 Expr.codeToExpr (Expr.generateCtor mode ctorName Index.first 1)
344 Mode.Prod _ _ ->
345 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
346 in
347 JS.Var [ (Name.fromGlobal home name, Just definition) ]
351-- GENERATE PORTS
354generatePort :: Mode.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
355generatePort mode (Opt.Global home name) makePort converter =
356 let
357 definition =
358 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
359 [ JS.String (N.toBuilder name)
360 , Expr.codeToExpr (Expr.generate mode converter)
361 ]
362 in
363 JS.Var [ (Name.fromGlobal home name, Just definition) ]
367-- GENERATE MANAGER
370generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
371generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
372 let
373 managerLVar =
374 JS.LBracket
375 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
376 (JS.String (N.toBuilder moduleName))
378 (deps, args, stmts) =
379 generateManagerHelp home effectsType
381 createManager =
382 JS.ExprStmt $ JS.Assign managerLVar $
383 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
384 in
385 addStmt (List.foldl' (addGlobal mode graph) state deps) $
386 JS.Block (createManager : stmts)
389generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
390generateLeaf home@(ModuleName.Canonical _ moduleName) name =
391 let
392 definition =
393 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
394 in
395 JS.Var [ (Name.fromGlobal home name, Just definition) ]
398{-# NOINLINE leaf #-}
399leaf :: JS.Expr
400leaf =
401 JS.Ref (Name.fromKernel N.platform "leaf")
404generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
405generateManagerHelp home effectsType =
406 let
407 dep name = Opt.Global home name
408 ref name = JS.Ref (Name.fromGlobal home name)
409 in
410 case effectsType of
411 Opt.Cmd ->
412 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
413 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
414 , [ generateLeaf home "command" ]
415 )
417 Opt.Sub ->
418 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
419 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
420 , [ generateLeaf home "subscription" ]
421 )
423 Opt.Fx ->
424 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
425 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
426 , [ generateLeaf home "command"
427 , generateLeaf home "subscription"
428 ]
429 )
433-- MAIN EXPORTS
436toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
437toMainExports mode mains =
438 let
439 export = Name.fromKernel N.platform "export"
440 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
441 in
442 Name.toBuilder export <> "(" <> exports <> ");"
445generateExports :: Mode.Mode -> Trie -> B.Builder
446generateExports mode (Trie maybeMain subs) =
447 let
448 object =
449 case Map.toList subs of
450 [] ->
451 "{}"
453 (name, subTrie) : otherSubTries ->
454 "{'" <> Text.encodeUtf8Builder name <> "':"
455 <> generateExports mode subTrie
456 <> List.foldl' (addSubTrie mode) "}" otherSubTries
457 in
458 case maybeMain of
459 Nothing ->
460 object
462 Just (home, main) ->
463 let initialize = Expr.generateMain mode home main in
464 JS.exprToBuilder initialize <> "(" <> object <> ")"
467addSubTrie :: Mode.Mode -> B.Builder -> (Text.Text, Trie) -> B.Builder
468addSubTrie mode end (name, trie) =
469 ",'" <> Text.encodeUtf8Builder name <> "':" <> generateExports mode trie <> end
473-- BUILD TRIES
476data Trie =
477 Trie
478 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
479 , _subs :: Map.Map Text.Text Trie
480 }
483emptyTrie :: Trie
484emptyTrie =
485 Trie Nothing Map.empty
488addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
489addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
490 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
493segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
494segmentsToTrie home segments main =
495 case segments of
496 [] ->
497 Trie (Just (home, main)) Map.empty
499 segment : otherSegments ->
500 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
503merge :: Trie -> Trie -> Trie
504merge (Trie main1 subs1) (Trie main2 subs2) =
505 Trie
506 (checkedMerge main1 main2)
507 (Map.unionWith merge subs1 subs2)
510checkedMerge :: Maybe a -> Maybe a -> Maybe a
511checkedMerge a b =
512 case (a, b) of
513 (Nothing, main) ->
514 main
516 (main, Nothing) ->
517 main
519 (Just _, Just _) ->
520 error "cannot have two modules with the same name"