git.iko.soy/elk
on 075be13 help sign in
elk/compiler/src/Generate/JavaScript.hs
554 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 stateToBuilder evalState
89 <> print ansi localizer home name tipe
92print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder
93print ansi localizer home name tipe =
94 let
95 value = JsName.toBuilder (JsName.fromGlobal home name)
96 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
97 tipeDoc = RT.canToDoc localizer RT.None tipe
98 bool = if ansi then "true" else "false"
99 in
100 "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
101 \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
102 \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
103 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
104 \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
105 \} else {\n\
106 \ _print(' : ' + _type);\n\
107 \}\n"
111-- GRAPH TRAVERSAL STATE
114data State =
115 State
116 { _revKernels :: [B.Builder]
117 , _revBuilders :: [B.Builder]
118 , _seenGlobals :: Set.Set Opt.Global
119 }
122emptyState :: State
123emptyState =
124 State mempty [] Set.empty
127stateToBuilder :: State -> B.Builder
128stateToBuilder (State revKernels revBuilders _) =
129 prependBuilders revKernels (prependBuilders revBuilders mempty)
132prependBuilders :: [B.Builder] -> B.Builder -> B.Builder
133prependBuilders revBuilders monolith =
134 List.foldl' (\m b -> b <> m) monolith revBuilders
138-- ADD DEPENDENCIES
141addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
142addGlobal mode graph state@(State revKernels builders seen) global =
143 if Set.member global seen then
144 state
145 else
146 addGlobalHelp mode graph global $
147 State revKernels builders (Set.insert global seen)
150addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
151addGlobalHelp mode graph global state =
152 let
153 addDeps deps someState =
154 Set.foldl' (addGlobal mode graph) someState deps
155 in
156 case graph ! global of
157 Opt.Define expr deps ->
158 addStmt (addDeps deps state) (
159 var global (Expr.generate mode expr)
160 )
162 Opt.DefineTailFunc argNames body deps ->
163 addStmt (addDeps deps state) (
164 let (Opt.Global _ name) = global in
165 var global (Expr.generateTailDef mode name argNames body)
166 )
168 Opt.Ctor index arity ->
169 addStmt state (
170 var global (Expr.generateCtor mode global index arity)
171 )
173 Opt.Link linkedGlobal ->
174 addGlobal mode graph state linkedGlobal
176 Opt.Cycle names values functions deps ->
177 addStmt (addDeps deps state) (
178 generateCycle mode global names values functions
179 )
181 Opt.Manager effectsType ->
182 generateManager mode graph global effectsType state
184 Opt.Kernel chunks deps ->
185 if isDebugger global && not (Mode.isDebug mode) then
186 state
187 else
188 addKernel (addDeps deps state) (generateKernel mode chunks)
190 Opt.Enum index ->
191 addStmt state (
192 generateEnum mode global index
193 )
195 Opt.Box ->
196 addStmt (addGlobal mode graph state identity) (
197 generateBox mode global
198 )
200 Opt.PortIncoming decoder deps ->
201 addStmt (addDeps deps state) (
202 generatePort mode global "incomingPort" decoder
203 )
205 Opt.PortOutgoing encoder deps ->
206 addStmt (addDeps deps state) (
207 generatePort mode global "outgoingPort" encoder
208 )
211addStmt :: State -> JS.Stmt -> State
212addStmt state stmt =
213 addBuilder state (JS.stmtToBuilder stmt)
216addBuilder :: State -> B.Builder -> State
217addBuilder (State revKernels revBuilders seen) builder =
218 State revKernels (builder:revBuilders) seen
221addKernel :: State -> B.Builder -> State
222addKernel (State revKernels revBuilders seen) kernel =
223 State (kernel:revKernels) revBuilders seen
226var :: Opt.Global -> Expr.Code -> JS.Stmt
227var (Opt.Global home name) code =
228 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)
231isDebugger :: Opt.Global -> Bool
232isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
233 home == Name.debugger
237-- GENERATE CYCLES
240generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
241generateCycle mode (Opt.Global home _) names values functions =
242 JS.Block
243 [ JS.Block $ map (generateCycleFunc mode home) functions
244 , JS.Block $ map (generateSafeCycle mode home) values
245 , case map (generateRealCycle home) values of
246 [] ->
247 JS.EmptyStmt
249 realBlock@(_:_) ->
250 case mode of
251 Mode.Prod _ ->
252 JS.Block realBlock
254 Mode.Dev _ ->
255 JS.Try (JS.Block realBlock) JsName.dollar $ JS.Throw $ JS.String $
256 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
257 <> drawCycle names
258 <> "\\n\\nThese errors are very tricky, so read "
259 <> B.stringUtf8 (D.makeNakedLink "halting-problem")
260 <> " to learn how to fix it!"
261 ]
264generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
265generateCycleFunc mode home def =
266 case def of
267 Opt.Def name expr ->
268 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))
270 Opt.TailDef name args expr ->
271 JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))
274generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
275generateSafeCycle mode home (name, expr) =
276 JS.FunctionStmt (JsName.fromCycle home name) [] $
277 Expr.codeToStmtList (Expr.generate mode expr)
280generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt
281generateRealCycle home (name, _) =
282 let
283 safeName = JsName.fromCycle home name
284 realName = JsName.fromGlobal home name
285 in
286 JS.Block
287 [ JS.Var realName (JS.Call (JS.Ref safeName) [])
288 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
289 JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
290 ]
293drawCycle :: [Name.Name] -> B.Builder
294drawCycle names =
295 let
296 topLine = "\\n ┌─────┐"
297 nameLine name = "\\n │ " <> Name.toBuilder name
298 midLine = "\\n │ ↓"
299 bottomLine = "\\n └─────┘"
300 in
301 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
305-- GENERATE KERNEL
308generateKernel :: Mode.Mode -> [K.Chunk] -> B.Builder
309generateKernel mode chunks =
310 List.foldr (addChunk mode) mempty chunks
313addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
314addChunk mode chunk builder =
315 case chunk of
316 K.JS javascript ->
317 B.byteString javascript <> builder
319 K.ElmVar home name ->
320 JsName.toBuilder (JsName.fromGlobal home name) <> builder
322 K.JsVar home name ->
323 JsName.toBuilder (JsName.fromKernel home name) <> builder
325 K.ElmField name ->
326 JsName.toBuilder (Expr.generateField mode name) <> builder
328 K.JsField int ->
329 JsName.toBuilder (JsName.fromInt int) <> builder
331 K.JsEnum int ->
332 B.intDec int <> builder
334 K.Debug ->
335 case mode of
336 Mode.Dev _ ->
337 builder
339 Mode.Prod _ ->
340 "_UNUSED" <> builder
342 K.Prod ->
343 case mode of
344 Mode.Dev _ ->
345 "_UNUSED" <> builder
347 Mode.Prod _ ->
348 builder
352-- GENERATE ENUM
355generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
356generateEnum mode global@(Opt.Global home name) index =
357 JS.Var (JsName.fromGlobal home name) $
358 case mode of
359 Mode.Dev _ ->
360 Expr.codeToExpr (Expr.generateCtor mode global index 0)
362 Mode.Prod _ ->
363 JS.Int (Index.toMachine index)
367-- GENERATE BOX
370generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
371generateBox mode global@(Opt.Global home name) =
372 JS.Var (JsName.fromGlobal home name) $
373 case mode of
374 Mode.Dev _ ->
375 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
377 Mode.Prod _ ->
378 JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
381{-# NOINLINE identity #-}
382identity :: Opt.Global
383identity =
384 Opt.Global ModuleName.basics Name.identity
388-- GENERATE PORTS
391generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
392generatePort mode (Opt.Global home name) makePort converter =
393 JS.Var (JsName.fromGlobal home name) $
394 JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
395 [ JS.String (Name.toBuilder name)
396 , Expr.codeToExpr (Expr.generate mode converter)
397 ]
401-- GENERATE MANAGER
404generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
405generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
406 let
407 managerLVar =
408 JS.LBracket
409 (JS.Ref (JsName.fromKernel Name.platform "effectManagers"))
410 (JS.String (Name.toBuilder moduleName))
412 (deps, args, stmts) =
413 generateManagerHelp home effectsType
415 createManager =
416 JS.ExprStmt $ JS.Assign managerLVar $
417 JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args
418 in
419 addStmt (List.foldl' (addGlobal mode graph) state deps) $
420 JS.Block (createManager : stmts)
423generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
424generateLeaf home@(ModuleName.Canonical _ moduleName) name =
425 JS.Var (JsName.fromGlobal home name) $
426 JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
430{-# NOINLINE leaf #-}
431leaf :: JS.Expr
432leaf =
433 JS.Ref (JsName.fromKernel Name.platform "leaf")
436generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
437generateManagerHelp home effectsType =
438 let
439 dep name = Opt.Global home name
440 ref name = JS.Ref (JsName.fromGlobal home name)
441 in
442 case effectsType of
443 Opt.Cmd ->
444 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
445 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
446 , [ generateLeaf home "command" ]
447 )
449 Opt.Sub ->
450 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
451 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
452 , [ generateLeaf home "subscription" ]
453 )
455 Opt.Fx ->
456 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
457 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
458 , [ generateLeaf home "command"
459 , generateLeaf home "subscription"
460 ]
461 )
465-- MAIN EXPORTS
468toMainExports :: Mode.Mode -> Mains -> B.Builder
469toMainExports mode mains =
470 let
471 export = JsName.fromKernel Name.platform "export"
472 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
473 in
474 JsName.toBuilder export <> "(" <> exports <> ");"
477generateExports :: Mode.Mode -> Trie -> B.Builder
478generateExports mode (Trie maybeMain subs) =
479 let
480 starter end =
481 case maybeMain of
482 Nothing ->
483 "{"
485 Just (home, main) ->
486 "{'init':"
487 <> JS.exprToBuilder (Expr.generateMain mode home main)
488 <> end
489 in
490 case Map.toList subs of
491 [] ->
492 starter "" <> "}"
494 (name, subTrie) : otherSubTries ->
495 starter "," <>
496 "'" <> Utf8.toBuilder name <> "':"
497 <> generateExports mode subTrie
498 <> List.foldl' (addSubTrie mode) "}" otherSubTries
501addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
502addSubTrie mode end (name, trie) =
503 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
507-- BUILD TRIES
510data Trie =
511 Trie
512 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
513 , _subs :: Map.Map Name.Name Trie
514 }
517emptyTrie :: Trie
518emptyTrie =
519 Trie Nothing Map.empty
522addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
523addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
524 merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
527segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
528segmentsToTrie home segments main =
529 case segments of
530 [] ->
531 Trie (Just (home, main)) Map.empty
533 segment : otherSegments ->
534 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
537merge :: Trie -> Trie -> Trie
538merge (Trie main1 subs1) (Trie main2 subs2) =
539 Trie
540 (checkedMerge main1 main2)
541 (Map.unionWith merge subs1 subs2)
544checkedMerge :: Maybe a -> Maybe a -> Maybe a
545checkedMerge a b =
546 case (a, b) of
547 (Nothing, main) ->
548 main
550 (main, Nothing) ->
551 main
553 (Just _, Just _) ->
554 error "cannot have two modules with the same name"