git.iko.soy/elk
on 7b60982 help sign in
elk/compiler/src/Generate/JavaScript.hs
569 lines 16 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, Just (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, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
270 Opt.TailDef name args expr ->
271 JS.Var [ (JsName.fromGlobal home name, Just (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, Just (JS.Call (JS.Ref safeName) []) ) ]
288 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
289 JS.Function Nothing [] [ JS.Return (Just (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 Utf8.toBuilder 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 let
358 definition =
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)
365 in
366 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
370-- GENERATE BOX
373generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
374generateBox mode global@(Opt.Global home name) =
375 let
376 definition =
377 case mode of
378 Mode.Dev _ ->
379 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
381 Mode.Prod _ ->
382 JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
383 in
384 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
387{-# NOINLINE identity #-}
388identity :: Opt.Global
389identity =
390 Opt.Global ModuleName.basics Name.identity
394-- GENERATE PORTS
397generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
398generatePort mode (Opt.Global home name) makePort converter =
399 let
400 definition =
401 JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
402 [ JS.String (Name.toBuilder name)
403 , Expr.codeToExpr (Expr.generate mode converter)
404 ]
405 in
406 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
410-- GENERATE MANAGER
413generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
414generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
415 let
416 managerLVar =
417 JS.LBracket
418 (JS.Ref (JsName.fromKernel Name.platform "effectManagers"))
419 (JS.String (Name.toBuilder moduleName))
421 (deps, args, stmts) =
422 generateManagerHelp home effectsType
424 createManager =
425 JS.ExprStmt $ JS.Assign managerLVar $
426 JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args
427 in
428 addStmt (List.foldl' (addGlobal mode graph) state deps) $
429 JS.Block (createManager : stmts)
432generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
433generateLeaf home@(ModuleName.Canonical _ moduleName) name =
434 let
435 definition =
436 JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
437 in
438 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
441{-# NOINLINE leaf #-}
442leaf :: JS.Expr
443leaf =
444 JS.Ref (JsName.fromKernel Name.platform "leaf")
447generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
448generateManagerHelp home effectsType =
449 let
450 dep name = Opt.Global home name
451 ref name = JS.Ref (JsName.fromGlobal home name)
452 in
453 case effectsType of
454 Opt.Cmd ->
455 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
456 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
457 , [ generateLeaf home "command" ]
458 )
460 Opt.Sub ->
461 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
462 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
463 , [ generateLeaf home "subscription" ]
464 )
466 Opt.Fx ->
467 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
468 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
469 , [ generateLeaf home "command"
470 , generateLeaf home "subscription"
471 ]
472 )
476-- MAIN EXPORTS
479toMainExports :: Mode.Mode -> Mains -> B.Builder
480toMainExports mode mains =
481 let
482 export = JsName.fromKernel Name.platform "export"
483 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
484 in
485 JsName.toBuilder export <> "(" <> exports <> ");"
488generateExports :: Mode.Mode -> Trie -> B.Builder
489generateExports mode (Trie maybeMain subs) =
490 let
491 starter end =
492 case maybeMain of
493 Nothing ->
494 "{"
496 Just (home, main) ->
497 "{'init':"
498 <> JS.exprToBuilder (Expr.generateMain mode home main)
499 <> end
500 in
501 case Map.toList subs of
502 [] ->
503 starter "" <> "}"
505 (name, subTrie) : otherSubTries ->
506 starter "," <>
507 "'" <> Utf8.toBuilder name <> "':"
508 <> generateExports mode subTrie
509 <> List.foldl' (addSubTrie mode) "}" otherSubTries
512addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder
513addSubTrie mode end (name, trie) =
514 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
518-- BUILD TRIES
521data Trie =
522 Trie
523 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
524 , _subs :: Map.Map Utf8.String Trie
525 }
528emptyTrie :: Trie
529emptyTrie =
530 Trie Nothing Map.empty
533addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
534addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
535 let
536 segments =
537 Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)
538 in
539 merge trie $ segmentsToTrie home segments main
542segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie
543segmentsToTrie home segments main =
544 case segments of
545 [] ->
546 Trie (Just (home, main)) Map.empty
548 segment : otherSegments ->
549 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
552merge :: Trie -> Trie -> Trie
553merge (Trie main1 subs1) (Trie main2 subs2) =
554 Trie
555 (checkedMerge main1 main2)
556 (Map.unionWith merge subs1 subs2)
559checkedMerge :: Maybe a -> Maybe a -> Maybe a
560checkedMerge a b =
561 case (a, b) of
562 (Nothing, main) ->
563 main
565 (main, Nothing) ->
566 main
568 (Just _, Just _) ->
569 error "cannot have two modules with the same name"