git.iko.soy/elk
on be29f51 help sign in
elk/compiler/src/Generate/JavaScript.hs
556 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 "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
89 <> Functions.functions
90 <> stateToBuilder evalState
91 <> print ansi localizer home name tipe
94print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder
95print ansi localizer home name tipe =
96 let
97 value = JsName.toBuilder (JsName.fromGlobal home name)
98 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
99 tipeDoc = RT.canToDoc localizer RT.None tipe
100 bool = if ansi then "true" else "false"
101 in
102 "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
103 \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
104 \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
105 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
106 \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
107 \} else {\n\
108 \ _print(' : ' + _type);\n\
109 \}\n"
113-- GRAPH TRAVERSAL STATE
116data State =
117 State
118 { _revKernels :: [B.Builder]
119 , _revBuilders :: [B.Builder]
120 , _seenGlobals :: Set.Set Opt.Global
121 }
124emptyState :: State
125emptyState =
126 State mempty [] Set.empty
129stateToBuilder :: State -> B.Builder
130stateToBuilder (State revKernels revBuilders _) =
131 prependBuilders revKernels (prependBuilders revBuilders mempty)
134prependBuilders :: [B.Builder] -> B.Builder -> B.Builder
135prependBuilders revBuilders monolith =
136 List.foldl' (\m b -> b <> m) monolith revBuilders
140-- ADD DEPENDENCIES
143addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
144addGlobal mode graph state@(State revKernels builders seen) global =
145 if Set.member global seen then
146 state
147 else
148 addGlobalHelp mode graph global $
149 State revKernels builders (Set.insert global seen)
152addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
153addGlobalHelp mode graph global state =
154 let
155 addDeps deps someState =
156 Set.foldl' (addGlobal mode graph) someState deps
157 in
158 case graph ! global of
159 Opt.Define expr deps ->
160 addStmt (addDeps deps state) (
161 var global (Expr.generate mode expr)
162 )
164 Opt.DefineTailFunc argNames body deps ->
165 addStmt (addDeps deps state) (
166 let (Opt.Global _ name) = global in
167 var global (Expr.generateTailDef mode name argNames body)
168 )
170 Opt.Ctor index arity ->
171 addStmt state (
172 var global (Expr.generateCtor mode global index arity)
173 )
175 Opt.Link linkedGlobal ->
176 addGlobal mode graph state linkedGlobal
178 Opt.Cycle names values functions deps ->
179 addStmt (addDeps deps state) (
180 generateCycle mode global names values functions
181 )
183 Opt.Manager effectsType ->
184 generateManager mode graph global effectsType state
186 Opt.Kernel chunks deps ->
187 if isDebugger global && not (Mode.isDebug mode) then
188 state
189 else
190 addKernel (addDeps deps state) (generateKernel mode chunks)
192 Opt.Enum index ->
193 addStmt state (
194 generateEnum mode global index
195 )
197 Opt.Box ->
198 addStmt (addGlobal mode graph state identity) (
199 generateBox mode global
200 )
202 Opt.PortIncoming decoder deps ->
203 addStmt (addDeps deps state) (
204 generatePort mode global "incomingPort" decoder
205 )
207 Opt.PortOutgoing encoder deps ->
208 addStmt (addDeps deps state) (
209 generatePort mode global "outgoingPort" encoder
210 )
213addStmt :: State -> JS.Stmt -> State
214addStmt state stmt =
215 addBuilder state (JS.stmtToBuilder stmt)
218addBuilder :: State -> B.Builder -> State
219addBuilder (State revKernels revBuilders seen) builder =
220 State revKernels (builder:revBuilders) seen
223addKernel :: State -> B.Builder -> State
224addKernel (State revKernels revBuilders seen) kernel =
225 State (kernel:revKernels) revBuilders seen
228var :: Opt.Global -> Expr.Code -> JS.Stmt
229var (Opt.Global home name) code =
230 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)
233isDebugger :: Opt.Global -> Bool
234isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
235 home == Name.debugger
239-- GENERATE CYCLES
242generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
243generateCycle mode (Opt.Global home _) names values functions =
244 JS.Block
245 [ JS.Block $ map (generateCycleFunc mode home) functions
246 , JS.Block $ map (generateSafeCycle mode home) values
247 , case map (generateRealCycle home) values of
248 [] ->
249 JS.EmptyStmt
251 realBlock@(_:_) ->
252 case mode of
253 Mode.Prod _ ->
254 JS.Block realBlock
256 Mode.Dev _ ->
257 JS.Try (JS.Block realBlock) JsName.dollar $ JS.Throw $ JS.String $
258 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
259 <> drawCycle names
260 <> "\\n\\nThese errors are very tricky, so read "
261 <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
262 <> " to learn how to fix it!"
263 ]
266generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
267generateCycleFunc mode home def =
268 case def of
269 Opt.Def name expr ->
270 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))
272 Opt.TailDef name args expr ->
273 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))
276generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
277generateSafeCycle mode home (name, expr) =
278 JS.FunctionStmt (JsName.fromCycle home name) [] $
279 Expr.codeToStmtList (Expr.generate mode expr)
282generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt
283generateRealCycle home (name, _) =
284 let
285 safeName = JsName.fromCycle home name
286 realName = JsName.fromGlobal home name
287 in
288 JS.Block
289 [ JS.Var realName (JS.Call (JS.Ref safeName) [])
290 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
291 JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
292 ]
295drawCycle :: [Name.Name] -> B.Builder
296drawCycle names =
297 let
298 topLine = "\\n ┌─────┐"
299 nameLine name = "\\n │ " <> Name.toBuilder name
300 midLine = "\\n │ ↓"
301 bottomLine = "\\n └─────┘"
302 in
303 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
307-- GENERATE KERNEL
310generateKernel :: Mode.Mode -> [K.Chunk] -> B.Builder
311generateKernel mode chunks =
312 List.foldr (addChunk mode) mempty chunks
315addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
316addChunk mode chunk builder =
317 case chunk of
318 K.JS javascript ->
319 B.byteString javascript <> builder
321 K.ElmVar home name ->
322 JsName.toBuilder (JsName.fromGlobal home name) <> builder
324 K.JsVar home name ->
325 JsName.toBuilder (JsName.fromKernel home name) <> builder
327 K.ElmField name ->
328 JsName.toBuilder (Expr.generateField mode name) <> builder
330 K.JsField int ->
331 JsName.toBuilder (JsName.fromInt int) <> builder
333 K.JsEnum int ->
334 B.intDec int <> builder
336 K.Debug ->
337 case mode of
338 Mode.Dev _ ->
339 builder
341 Mode.Prod _ ->
342 "_UNUSED" <> builder
344 K.Prod ->
345 case mode of
346 Mode.Dev _ ->
347 "_UNUSED" <> builder
349 Mode.Prod _ ->
350 builder
354-- GENERATE ENUM
357generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
358generateEnum mode global@(Opt.Global home name) index =
359 JS.Var (JsName.fromGlobal home name) $
360 case mode of
361 Mode.Dev _ ->
362 Expr.codeToExpr (Expr.generateCtor mode global index 0)
364 Mode.Prod _ ->
365 JS.Int (Index.toMachine index)
369-- GENERATE BOX
372generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
373generateBox mode global@(Opt.Global home name) =
374 JS.Var (JsName.fromGlobal home name) $
375 case mode of
376 Mode.Dev _ ->
377 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
379 Mode.Prod _ ->
380 JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
383{-# NOINLINE identity #-}
384identity :: Opt.Global
385identity =
386 Opt.Global ModuleName.basics Name.identity
390-- GENERATE PORTS
393generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
394generatePort mode (Opt.Global home name) makePort converter =
395 JS.Var (JsName.fromGlobal home name) $
396 JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
397 [ JS.String (Name.toBuilder name)
398 , Expr.codeToExpr (Expr.generate mode converter)
399 ]
403-- GENERATE MANAGER
406generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
407generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
408 let
409 managerLVar =
410 JS.LBracket
411 (JS.Ref (JsName.fromKernel Name.platform "effectManagers"))
412 (JS.String (Name.toBuilder moduleName))
414 (deps, args, stmts) =
415 generateManagerHelp home effectsType
417 createManager =
418 JS.ExprStmt $ JS.Assign managerLVar $
419 JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args
420 in
421 addStmt (List.foldl' (addGlobal mode graph) state deps) $
422 JS.Block (createManager : stmts)
425generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
426generateLeaf home@(ModuleName.Canonical _ moduleName) name =
427 JS.Var (JsName.fromGlobal home name) $
428 JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
432{-# NOINLINE leaf #-}
433leaf :: JS.Expr
434leaf =
435 JS.Ref (JsName.fromKernel Name.platform "leaf")
438generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
439generateManagerHelp home effectsType =
440 let
441 dep name = Opt.Global home name
442 ref name = JS.Ref (JsName.fromGlobal home name)
443 in
444 case effectsType of
445 Opt.Cmd ->
446 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
447 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
448 , [ generateLeaf home "command" ]
449 )
451 Opt.Sub ->
452 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
453 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
454 , [ generateLeaf home "subscription" ]
455 )
457 Opt.Fx ->
458 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
459 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
460 , [ generateLeaf home "command"
461 , generateLeaf home "subscription"
462 ]
463 )
467-- MAIN EXPORTS
470toMainExports :: Mode.Mode -> Mains -> B.Builder
471toMainExports mode mains =
472 let
473 export = JsName.fromKernel Name.platform "export"
474 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
475 in
476 JsName.toBuilder export <> "(" <> exports <> ");"
479generateExports :: Mode.Mode -> Trie -> B.Builder
480generateExports mode (Trie maybeMain subs) =
481 let
482 starter end =
483 case maybeMain of
484 Nothing ->
485 "{"
487 Just (home, main) ->
488 "{'init':"
489 <> JS.exprToBuilder (Expr.generateMain mode home main)
490 <> end
491 in
492 case Map.toList subs of
493 [] ->
494 starter "" <> "}"
496 (name, subTrie) : otherSubTries ->
497 starter "," <>
498 "'" <> Utf8.toBuilder name <> "':"
499 <> generateExports mode subTrie
500 <> List.foldl' (addSubTrie mode) "}" otherSubTries
503addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
504addSubTrie mode end (name, trie) =
505 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
509-- BUILD TRIES
512data Trie =
513 Trie
514 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
515 , _subs :: Map.Map Name.Name Trie
516 }
519emptyTrie :: Trie
520emptyTrie =
521 Trie Nothing Map.empty
524addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
525addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
526 merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
529segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
530segmentsToTrie home segments main =
531 case segments of
532 [] ->
533 Trie (Just (home, main)) Map.empty
535 segment : otherSegments ->
536 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
539merge :: Trie -> Trie -> Trie
540merge (Trie main1 subs1) (Trie main2 subs2) =
541 Trie
542 (checkedMerge main1 main2)
543 (Map.unionWith merge subs1 subs2)
546checkedMerge :: Maybe a -> Maybe a -> Maybe a
547checkedMerge a b =
548 case (a, b) of
549 (Nothing, main) ->
550 main
552 (main, Nothing) ->
553 main
555 (Just _, Just _) ->
556 error "cannot have two modules with the same name"