git.iko.soy/elk
on a009cea help sign in
elk/compiler/src/Generate/JavaScript.hs
590 lines 17 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript
3 ( generate
4 , generateForRepl
5 , generateForReplEndpoint
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.Name as Name
17import qualified Data.Set as Set
18import qualified Data.Utf8 as Utf8
20import qualified AST.Canonical as Can
21import qualified AST.Optimized as Opt
22import qualified Data.Index as Index
23import qualified Elm.Kernel as K
24import qualified Elm.ModuleName as ModuleName
25import qualified Generate.JavaScript.Builder as JS
26import qualified Generate.JavaScript.Expression as Expr
27import qualified Generate.JavaScript.Functions as Functions
28import qualified Generate.JavaScript.Name as JsName
29import qualified Generate.Mode as Mode
30import qualified Reporting.Doc as D
31import qualified Reporting.Render.Type as RT
32import qualified Reporting.Render.Type.Localizer as L
36-- GENERATE
39type Graph = Map.Map Opt.Global Opt.Node
40type Mains = Map.Map ModuleName.Canonical Opt.Main
43generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder
44generate mode (Opt.GlobalGraph graph _) mains =
45 let
46 state = Map.foldrWithKey (addMain mode graph) emptyState mains
47 in
48 "(function(scope){\n'use strict';"
49 <> Functions.functions
50 <> perfNote mode
51 <> stateToBuilder state
52 <> toMainExports mode mains
53 <> "}(this));"
56addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State
57addMain mode graph home _ state =
58 addGlobal mode graph state (Opt.Global home "main")
61perfNote :: Mode.Mode -> B.Builder
62perfNote mode =
63 case mode of
64 Mode.Prod _ ->
65 ""
67 Mode.Dev Nothing ->
68 "console.warn('Compiled in DEV mode. Follow the advice at "
69 <> B.stringUtf8 (D.makeNakedLink "optimize")
70 <> " for better performance and smaller assets.');"
72 Mode.Dev (Just _) ->
73 "console.warn('Compiled in DEBUG mode. Follow the advice at "
74 <> B.stringUtf8 (D.makeNakedLink "optimize")
75 <> " for better performance and smaller assets.');"
79-- GENERATE FOR REPL
82generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
83generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) =
84 let
85 mode = Mode.Dev Nothing
86 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
87 evalState = addGlobal mode graph debugState (Opt.Global home name)
88 in
89 "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
90 <> Functions.functions
91 <> stateToBuilder evalState
92 <> print ansi localizer home name tipe
95print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder
96print ansi localizer home name tipe =
97 let
98 value = JsName.toBuilder (JsName.fromGlobal home name)
99 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
100 tipeDoc = RT.canToDoc localizer RT.None tipe
101 bool = if ansi then "true" else "false"
102 in
103 "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
104 \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
105 \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
106 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
107 \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
108 \} else {\n\
109 \ _print(' : ' + _type);\n\
110 \}\n"
114-- GENERATE FOR REPL ENDPOINT
117generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder
118generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =
119 let
120 name = maybe Name.replValueToPrint id maybeName
121 mode = Mode.Dev Nothing
122 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
123 evalState = addGlobal mode graph debugState (Opt.Global home name)
124 in
125 Functions.functions
126 <> stateToBuilder evalState
127 <> postMessage localizer home maybeName tipe
130postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder
131postMessage localizer home maybeName tipe =
132 let
133 name = maybe Name.replValueToPrint id maybeName
134 value = JsName.toBuilder (JsName.fromGlobal home name)
135 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
136 tipeDoc = RT.canToDoc localizer RT.None tipe
137 toName n = "\"" <> Name.toBuilder n <> "\""
138 in
139 "self.postMessage({\n\
140 \ name: " <> maybe "null" toName maybeName <> ",\n\
141 \ value: " <> toString <> "(true, " <> value <> "),\n\
142 \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\
143 \});\n"
147-- GRAPH TRAVERSAL STATE
150data State =
151 State
152 { _revKernels :: [B.Builder]
153 , _revBuilders :: [B.Builder]
154 , _seenGlobals :: Set.Set Opt.Global
155 }
158emptyState :: State
159emptyState =
160 State mempty [] Set.empty
163stateToBuilder :: State -> B.Builder
164stateToBuilder (State revKernels revBuilders _) =
165 prependBuilders revKernels (prependBuilders revBuilders mempty)
168prependBuilders :: [B.Builder] -> B.Builder -> B.Builder
169prependBuilders revBuilders monolith =
170 List.foldl' (\m b -> b <> m) monolith revBuilders
174-- ADD DEPENDENCIES
177addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
178addGlobal mode graph state@(State revKernels builders seen) global =
179 if Set.member global seen then
180 state
181 else
182 addGlobalHelp mode graph global $
183 State revKernels builders (Set.insert global seen)
186addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
187addGlobalHelp mode graph global state =
188 let
189 addDeps deps someState =
190 Set.foldl' (addGlobal mode graph) someState deps
191 in
192 case graph ! global of
193 Opt.Define expr deps ->
194 addStmt (addDeps deps state) (
195 var global (Expr.generate mode expr)
196 )
198 Opt.DefineTailFunc argNames body deps ->
199 addStmt (addDeps deps state) (
200 let (Opt.Global _ name) = global in
201 var global (Expr.generateTailDef mode name argNames body)
202 )
204 Opt.Ctor index arity ->
205 addStmt state (
206 var global (Expr.generateCtor mode global index arity)
207 )
209 Opt.Link linkedGlobal ->
210 addGlobal mode graph state linkedGlobal
212 Opt.Cycle names values functions deps ->
213 addStmt (addDeps deps state) (
214 generateCycle mode global names values functions
215 )
217 Opt.Manager effectsType ->
218 generateManager mode graph global effectsType state
220 Opt.Kernel chunks deps ->
221 if isDebugger global && not (Mode.isDebug mode) then
222 state
223 else
224 addKernel (addDeps deps state) (generateKernel mode chunks)
226 Opt.Enum index ->
227 addStmt state (
228 generateEnum mode global index
229 )
231 Opt.Box ->
232 addStmt (addGlobal mode graph state identity) (
233 generateBox mode global
234 )
236 Opt.PortIncoming decoder deps ->
237 addStmt (addDeps deps state) (
238 generatePort mode global "incomingPort" decoder
239 )
241 Opt.PortOutgoing encoder deps ->
242 addStmt (addDeps deps state) (
243 generatePort mode global "outgoingPort" encoder
244 )
247addStmt :: State -> JS.Stmt -> State
248addStmt state stmt =
249 addBuilder state (JS.stmtToBuilder stmt)
252addBuilder :: State -> B.Builder -> State
253addBuilder (State revKernels revBuilders seen) builder =
254 State revKernels (builder:revBuilders) seen
257addKernel :: State -> B.Builder -> State
258addKernel (State revKernels revBuilders seen) kernel =
259 State (kernel:revKernels) revBuilders seen
262var :: Opt.Global -> Expr.Code -> JS.Stmt
263var (Opt.Global home name) code =
264 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)
267isDebugger :: Opt.Global -> Bool
268isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
269 home == Name.debugger
273-- GENERATE CYCLES
276generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
277generateCycle mode (Opt.Global home _) names values functions =
278 JS.Block
279 [ JS.Block $ map (generateCycleFunc mode home) functions
280 , JS.Block $ map (generateSafeCycle mode home) values
281 , case map (generateRealCycle home) values of
282 [] ->
283 JS.EmptyStmt
285 realBlock@(_:_) ->
286 case mode of
287 Mode.Prod _ ->
288 JS.Block realBlock
290 Mode.Dev _ ->
291 JS.Try (JS.Block realBlock) JsName.dollar $ JS.Throw $ JS.String $
292 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
293 <> drawCycle names
294 <> "\\n\\nThese errors are very tricky, so read "
295 <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
296 <> " to learn how to fix it!"
297 ]
300generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
301generateCycleFunc mode home def =
302 case def of
303 Opt.Def name expr ->
304 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))
306 Opt.TailDef name args expr ->
307 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))
310generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
311generateSafeCycle mode home (name, expr) =
312 JS.FunctionStmt (JsName.fromCycle home name) [] $
313 Expr.codeToStmtList (Expr.generate mode expr)
316generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt
317generateRealCycle home (name, _) =
318 let
319 safeName = JsName.fromCycle home name
320 realName = JsName.fromGlobal home name
321 in
322 JS.Block
323 [ JS.Var realName (JS.Call (JS.Ref safeName) [])
324 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
325 JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
326 ]
329drawCycle :: [Name.Name] -> B.Builder
330drawCycle names =
331 let
332 topLine = "\\n ┌─────┐"
333 nameLine name = "\\n │ " <> Name.toBuilder name
334 midLine = "\\n │ ↓"
335 bottomLine = "\\n └─────┘"
336 in
337 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
341-- GENERATE KERNEL
344generateKernel :: Mode.Mode -> [K.Chunk] -> B.Builder
345generateKernel mode chunks =
346 List.foldr (addChunk mode) mempty chunks
349addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
350addChunk mode chunk builder =
351 case chunk of
352 K.JS javascript ->
353 B.byteString javascript <> builder
355 K.ElmVar home name ->
356 JsName.toBuilder (JsName.fromGlobal home name) <> builder
358 K.JsVar home name ->
359 JsName.toBuilder (JsName.fromKernel home name) <> builder
361 K.ElmField name ->
362 JsName.toBuilder (Expr.generateField mode name) <> builder
364 K.JsField int ->
365 JsName.toBuilder (JsName.fromInt int) <> builder
367 K.JsEnum int ->
368 B.intDec int <> builder
370 K.Debug ->
371 case mode of
372 Mode.Dev _ ->
373 builder
375 Mode.Prod _ ->
376 "_UNUSED" <> builder
378 K.Prod ->
379 case mode of
380 Mode.Dev _ ->
381 "_UNUSED" <> builder
383 Mode.Prod _ ->
384 builder
388-- GENERATE ENUM
391generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
392generateEnum mode global@(Opt.Global home name) index =
393 JS.Var (JsName.fromGlobal home name) $
394 case mode of
395 Mode.Dev _ ->
396 Expr.codeToExpr (Expr.generateCtor mode global index 0)
398 Mode.Prod _ ->
399 JS.Int (Index.toMachine index)
403-- GENERATE BOX
406generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
407generateBox mode global@(Opt.Global home name) =
408 JS.Var (JsName.fromGlobal home name) $
409 case mode of
410 Mode.Dev _ ->
411 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
413 Mode.Prod _ ->
414 JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
417{-# NOINLINE identity #-}
418identity :: Opt.Global
419identity =
420 Opt.Global ModuleName.basics Name.identity
424-- GENERATE PORTS
427generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
428generatePort mode (Opt.Global home name) makePort converter =
429 JS.Var (JsName.fromGlobal home name) $
430 JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
431 [ JS.String (Name.toBuilder name)
432 , Expr.codeToExpr (Expr.generate mode converter)
433 ]
437-- GENERATE MANAGER
440generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
441generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
442 let
443 managerLVar =
444 JS.LBracket
445 (JS.Ref (JsName.fromKernel Name.platform "effectManagers"))
446 (JS.String (Name.toBuilder moduleName))
448 (deps, args, stmts) =
449 generateManagerHelp home effectsType
451 createManager =
452 JS.ExprStmt $ JS.Assign managerLVar $
453 JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args
454 in
455 addStmt (List.foldl' (addGlobal mode graph) state deps) $
456 JS.Block (createManager : stmts)
459generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
460generateLeaf home@(ModuleName.Canonical _ moduleName) name =
461 JS.Var (JsName.fromGlobal home name) $
462 JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
466{-# NOINLINE leaf #-}
467leaf :: JS.Expr
468leaf =
469 JS.Ref (JsName.fromKernel Name.platform "leaf")
472generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
473generateManagerHelp home effectsType =
474 let
475 dep name = Opt.Global home name
476 ref name = JS.Ref (JsName.fromGlobal home name)
477 in
478 case effectsType of
479 Opt.Cmd ->
480 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
481 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
482 , [ generateLeaf home "command" ]
483 )
485 Opt.Sub ->
486 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
487 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
488 , [ generateLeaf home "subscription" ]
489 )
491 Opt.Fx ->
492 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
493 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
494 , [ generateLeaf home "command"
495 , generateLeaf home "subscription"
496 ]
497 )
501-- MAIN EXPORTS
504toMainExports :: Mode.Mode -> Mains -> B.Builder
505toMainExports mode mains =
506 let
507 export = JsName.fromKernel Name.platform "export"
508 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
509 in
510 JsName.toBuilder export <> "(" <> exports <> ");"
513generateExports :: Mode.Mode -> Trie -> B.Builder
514generateExports mode (Trie maybeMain subs) =
515 let
516 starter end =
517 case maybeMain of
518 Nothing ->
519 "{"
521 Just (home, main) ->
522 "{'init':"
523 <> JS.exprToBuilder (Expr.generateMain mode home main)
524 <> end
525 in
526 case Map.toList subs of
527 [] ->
528 starter "" <> "}"
530 (name, subTrie) : otherSubTries ->
531 starter "," <>
532 "'" <> Utf8.toBuilder name <> "':"
533 <> generateExports mode subTrie
534 <> List.foldl' (addSubTrie mode) "}" otherSubTries
537addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
538addSubTrie mode end (name, trie) =
539 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
543-- BUILD TRIES
546data Trie =
547 Trie
548 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
549 , _subs :: Map.Map Name.Name Trie
550 }
553emptyTrie :: Trie
554emptyTrie =
555 Trie Nothing Map.empty
558addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
559addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
560 merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
563segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
564segmentsToTrie home segments main =
565 case segments of
566 [] ->
567 Trie (Just (home, main)) Map.empty
569 segment : otherSegments ->
570 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
573merge :: Trie -> Trie -> Trie
574merge (Trie main1 subs1) (Trie main2 subs2) =
575 Trie
576 (checkedMerge main1 main2)
577 (Map.unionWith merge subs1 subs2)
580checkedMerge :: Maybe a -> Maybe a -> Maybe a
581checkedMerge a b =
582 case (a, b) of
583 (Nothing, main) ->
584 main
586 (main, Nothing) ->
587 main
589 (Just _, Just _) ->
590 error "cannot have two modules with the same name"