git.iko.soy/elk
on b590547 help sign in
elk/compiler/src/Generate/JavaScript.hs
555 lines 15 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript
3 ( generate
4 , generateForRepl
5 )
6 where
9import Prelude hiding (cycle, print)
10import qualified Data.ByteString.Builder as B
11import Data.Monoid ((<>))
12import qualified Data.List as List
13import Data.Map ((!))
14import qualified Data.Map as Map
15import qualified Data.Name as Name
16import qualified Data.Set as Set
17import qualified Data.Utf8 as Utf8
19import qualified AST.Canonical as Can
20import qualified AST.Optimized as Opt
21import qualified Data.Index as Index
22import qualified Elm.Kernel as K
23import qualified Elm.ModuleName as ModuleName
24import qualified Generate.JavaScript.Builder as JS
25import qualified Generate.JavaScript.Expression as Expr
26import qualified Generate.JavaScript.Functions as Functions
27import qualified Generate.JavaScript.Name as JsName
28import qualified Generate.Mode as Mode
29import qualified Reporting.Doc as D
30import qualified Reporting.Render.Type as RT
31import qualified Reporting.Render.Type.Localizer as L
35-- GENERATE
38type Graph = Map.Map Opt.Global Opt.Node
39type Mains = Map.Map ModuleName.Canonical Opt.Main
42generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder
43generate mode (Opt.GlobalGraph graph _) mains =
44 let
45 state = Map.foldrWithKey (addMain mode graph) emptyState mains
46 in
47 "(function(scope){\n'use strict';"
48 <> Functions.functions
49 <> perfNote mode
50 <> stateToBuilder state
51 <> toMainExports mode mains
52 <> "}(this));"
55addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State
56addMain mode graph home _ state =
57 addGlobal mode graph state (Opt.Global home "main")
60perfNote :: Mode.Mode -> B.Builder
61perfNote mode =
62 case mode of
63 Mode.Prod _ ->
64 ""
66 Mode.Dev Nothing ->
67 "console.warn('Compiled in DEV mode. Follow the advice at "
68 <> B.stringUtf8 (D.makeNakedLink "optimize")
69 <> " for better performance and smaller assets.');"
71 Mode.Dev (Just _) ->
72 "console.warn('Compiled in DEBUG mode. Follow the advice at "
73 <> B.stringUtf8 (D.makeNakedLink "optimize")
74 <> " for better performance and smaller assets.');"
78-- GENERATE FOR REPL
81generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
82generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) =
83 let
84 mode = Mode.Dev Nothing
85 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
86 evalState = addGlobal mode graph debugState (Opt.Global home name)
87 in
88 Functions.functions
89 <> stateToBuilder evalState
90 <> print ansi localizer home name tipe
93print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder
94print ansi localizer home name tipe =
95 let
96 value = JsName.toBuilder (JsName.fromGlobal home name)
97 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
98 tipeDoc = RT.canToDoc localizer RT.None tipe
99 bool = if ansi then "true" else "false"
100 in
101 "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
102 \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
103 \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
104 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
105 \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
106 \} else {\n\
107 \ _print(' : ' + _type);\n\
108 \}\n"
112-- GRAPH TRAVERSAL STATE
115data State =
116 State
117 { _revKernels :: [B.Builder]
118 , _revBuilders :: [B.Builder]
119 , _seenGlobals :: Set.Set Opt.Global
120 }
123emptyState :: State
124emptyState =
125 State mempty [] Set.empty
128stateToBuilder :: State -> B.Builder
129stateToBuilder (State revKernels revBuilders _) =
130 prependBuilders revKernels (prependBuilders revBuilders mempty)
133prependBuilders :: [B.Builder] -> B.Builder -> B.Builder
134prependBuilders revBuilders monolith =
135 List.foldl' (\m b -> b <> m) monolith revBuilders
139-- ADD DEPENDENCIES
142addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
143addGlobal mode graph state@(State revKernels builders seen) global =
144 if Set.member global seen then
145 state
146 else
147 addGlobalHelp mode graph global $
148 State revKernels builders (Set.insert global seen)
151addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
152addGlobalHelp mode graph global state =
153 let
154 addDeps deps someState =
155 Set.foldl' (addGlobal mode graph) someState deps
156 in
157 case graph ! global of
158 Opt.Define expr deps ->
159 addStmt (addDeps deps state) (
160 var global (Expr.generate mode expr)
161 )
163 Opt.DefineTailFunc argNames body deps ->
164 addStmt (addDeps deps state) (
165 let (Opt.Global _ name) = global in
166 var global (Expr.generateTailDef mode name argNames body)
167 )
169 Opt.Ctor index arity ->
170 addStmt state (
171 var global (Expr.generateCtor mode global index arity)
172 )
174 Opt.Link linkedGlobal ->
175 addGlobal mode graph state linkedGlobal
177 Opt.Cycle names values functions deps ->
178 addStmt (addDeps deps state) (
179 generateCycle mode global names values functions
180 )
182 Opt.Manager effectsType ->
183 generateManager mode graph global effectsType state
185 Opt.Kernel chunks deps ->
186 if isDebugger global && not (Mode.isDebug mode) then
187 state
188 else
189 addKernel (addDeps deps state) (generateKernel mode chunks)
191 Opt.Enum index ->
192 addStmt state (
193 generateEnum mode global index
194 )
196 Opt.Box ->
197 addStmt (addGlobal mode graph state identity) (
198 generateBox mode global
199 )
201 Opt.PortIncoming decoder deps ->
202 addStmt (addDeps deps state) (
203 generatePort mode global "incomingPort" decoder
204 )
206 Opt.PortOutgoing encoder deps ->
207 addStmt (addDeps deps state) (
208 generatePort mode global "outgoingPort" encoder
209 )
212addStmt :: State -> JS.Stmt -> State
213addStmt state stmt =
214 addBuilder state (JS.stmtToBuilder stmt)
217addBuilder :: State -> B.Builder -> State
218addBuilder (State revKernels revBuilders seen) builder =
219 State revKernels (builder:revBuilders) seen
222addKernel :: State -> B.Builder -> State
223addKernel (State revKernels revBuilders seen) kernel =
224 State (kernel:revKernels) revBuilders seen
227var :: Opt.Global -> Expr.Code -> JS.Stmt
228var (Opt.Global home name) code =
229 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)
232isDebugger :: Opt.Global -> Bool
233isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
234 home == Name.debugger
238-- GENERATE CYCLES
241generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
242generateCycle mode (Opt.Global home _) names values functions =
243 JS.Block
244 [ JS.Block $ map (generateCycleFunc mode home) functions
245 , JS.Block $ map (generateSafeCycle mode home) values
246 , case map (generateRealCycle home) values of
247 [] ->
248 JS.EmptyStmt
250 realBlock@(_:_) ->
251 case mode of
252 Mode.Prod _ ->
253 JS.Block realBlock
255 Mode.Dev _ ->
256 JS.Try (JS.Block realBlock) JsName.dollar $ JS.Throw $ JS.String $
257 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
258 <> drawCycle names
259 <> "\\n\\nThese errors are very tricky, so read "
260 <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
261 <> " to learn how to fix it!"
262 ]
265generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
266generateCycleFunc mode home def =
267 case def of
268 Opt.Def name expr ->
269 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))
271 Opt.TailDef name args expr ->
272 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))
275generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
276generateSafeCycle mode home (name, expr) =
277 JS.FunctionStmt (JsName.fromCycle home name) [] $
278 Expr.codeToStmtList (Expr.generate mode expr)
281generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt
282generateRealCycle home (name, _) =
283 let
284 safeName = JsName.fromCycle home name
285 realName = JsName.fromGlobal home name
286 in
287 JS.Block
288 [ JS.Var realName (JS.Call (JS.Ref safeName) [])
289 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
290 JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
291 ]
294drawCycle :: [Name.Name] -> B.Builder
295drawCycle names =
296 let
297 topLine = "\\n ┌─────┐"
298 nameLine name = "\\n │ " <> Name.toBuilder name
299 midLine = "\\n │ ↓"
300 bottomLine = "\\n └─────┘"
301 in
302 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
306-- GENERATE KERNEL
309generateKernel :: Mode.Mode -> [K.Chunk] -> B.Builder
310generateKernel mode chunks =
311 List.foldr (addChunk mode) mempty chunks
314addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
315addChunk mode chunk builder =
316 case chunk of
317 K.JS javascript ->
318 B.byteString javascript <> builder
320 K.ElmVar home name ->
321 JsName.toBuilder (JsName.fromGlobal home name) <> builder
323 K.JsVar home name ->
324 JsName.toBuilder (JsName.fromKernel home name) <> builder
326 K.ElmField name ->
327 JsName.toBuilder (Expr.generateField mode name) <> builder
329 K.JsField int ->
330 JsName.toBuilder (JsName.fromInt int) <> builder
332 K.JsEnum int ->
333 B.intDec int <> builder
335 K.Debug ->
336 case mode of
337 Mode.Dev _ ->
338 builder
340 Mode.Prod _ ->
341 "_UNUSED" <> builder
343 K.Prod ->
344 case mode of
345 Mode.Dev _ ->
346 "_UNUSED" <> builder
348 Mode.Prod _ ->
349 builder
353-- GENERATE ENUM
356generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
357generateEnum mode global@(Opt.Global home name) index =
358 JS.Var (JsName.fromGlobal home name) $
359 case mode of
360 Mode.Dev _ ->
361 Expr.codeToExpr (Expr.generateCtor mode global index 0)
363 Mode.Prod _ ->
364 JS.Int (Index.toMachine index)
368-- GENERATE BOX
371generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
372generateBox mode global@(Opt.Global home name) =
373 JS.Var (JsName.fromGlobal home name) $
374 case mode of
375 Mode.Dev _ ->
376 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
378 Mode.Prod _ ->
379 JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
382{-# NOINLINE identity #-}
383identity :: Opt.Global
384identity =
385 Opt.Global ModuleName.basics Name.identity
389-- GENERATE PORTS
392generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
393generatePort mode (Opt.Global home name) makePort converter =
394 JS.Var (JsName.fromGlobal home name) $
395 JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
396 [ JS.String (Name.toBuilder name)
397 , Expr.codeToExpr (Expr.generate mode converter)
398 ]
402-- GENERATE MANAGER
405generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
406generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
407 let
408 managerLVar =
409 JS.LBracket
410 (JS.Ref (JsName.fromKernel Name.platform "effectManagers"))
411 (JS.String (Name.toBuilder moduleName))
413 (deps, args, stmts) =
414 generateManagerHelp home effectsType
416 createManager =
417 JS.ExprStmt $ JS.Assign managerLVar $
418 JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args
419 in
420 addStmt (List.foldl' (addGlobal mode graph) state deps) $
421 JS.Block (createManager : stmts)
424generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
425generateLeaf home@(ModuleName.Canonical _ moduleName) name =
426 JS.Var (JsName.fromGlobal home name) $
427 JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
431{-# NOINLINE leaf #-}
432leaf :: JS.Expr
433leaf =
434 JS.Ref (JsName.fromKernel Name.platform "leaf")
437generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
438generateManagerHelp home effectsType =
439 let
440 dep name = Opt.Global home name
441 ref name = JS.Ref (JsName.fromGlobal home name)
442 in
443 case effectsType of
444 Opt.Cmd ->
445 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
446 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
447 , [ generateLeaf home "command" ]
448 )
450 Opt.Sub ->
451 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
452 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
453 , [ generateLeaf home "subscription" ]
454 )
456 Opt.Fx ->
457 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
458 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
459 , [ generateLeaf home "command"
460 , generateLeaf home "subscription"
461 ]
462 )
466-- MAIN EXPORTS
469toMainExports :: Mode.Mode -> Mains -> B.Builder
470toMainExports mode mains =
471 let
472 export = JsName.fromKernel Name.platform "export"
473 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
474 in
475 JsName.toBuilder export <> "(" <> exports <> ");"
478generateExports :: Mode.Mode -> Trie -> B.Builder
479generateExports mode (Trie maybeMain subs) =
480 let
481 starter end =
482 case maybeMain of
483 Nothing ->
484 "{"
486 Just (home, main) ->
487 "{'init':"
488 <> JS.exprToBuilder (Expr.generateMain mode home main)
489 <> end
490 in
491 case Map.toList subs of
492 [] ->
493 starter "" <> "}"
495 (name, subTrie) : otherSubTries ->
496 starter "," <>
497 "'" <> Utf8.toBuilder name <> "':"
498 <> generateExports mode subTrie
499 <> List.foldl' (addSubTrie mode) "}" otherSubTries
502addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
503addSubTrie mode end (name, trie) =
504 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
508-- BUILD TRIES
511data Trie =
512 Trie
513 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
514 , _subs :: Map.Map Name.Name Trie
515 }
518emptyTrie :: Trie
519emptyTrie =
520 Trie Nothing Map.empty
523addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
524addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
525 merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
528segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
529segmentsToTrie home segments main =
530 case segments of
531 [] ->
532 Trie (Just (home, main)) Map.empty
534 segment : otherSegments ->
535 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
538merge :: Trie -> Trie -> Trie
539merge (Trie main1 subs1) (Trie main2 subs2) =
540 Trie
541 (checkedMerge main1 main2)
542 (Map.unionWith merge subs1 subs2)
545checkedMerge :: Maybe a -> Maybe a -> Maybe a
546checkedMerge a b =
547 case (a, b) of
548 (Nothing, main) ->
549 main
551 (main, Nothing) ->
552 main
554 (Just _, Just _) ->
555 error "cannot have two modules with the same name"