git.iko.soy/elk
on e7ca69f help sign in
elk/compiler/src/Generate/JavaScript.hs
579 lines 16 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript
3 ( Output(..)
4 , generate
5 , generateForRepl
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.Interface as I
24import qualified Elm.Kernel as K
25import qualified Elm.ModuleName as ModuleName
26import qualified Generate.JavaScript.Builder as JS
27import qualified Generate.JavaScript.Expression as Expr
28import qualified Generate.JavaScript.Name as JsName
29import qualified Generate.JavaScript.Mode as Mode
30import qualified Reporting.Render.Type as RT
31import qualified Reporting.Render.Type.Localizer as L
35-- GENERATE MAINS
38data Output
39 = None
40 | Some Name.Name [Name.Name] B.Builder
43generate :: Mode.Mode -> Opt.Graph -> [ModuleName.Canonical] -> Output
44generate mode (Opt.Graph mains graph _fields) roots =
45 let
46 rootSet = Set.fromList roots
47 rootMap = Map.restrictKeys mains rootSet
48 in
49 case map ModuleName._module (Map.keys rootMap) of
50 [] ->
51 None
53 name:names ->
54 let
55 state = Map.foldrWithKey (addMain mode graph) emptyState rootMap
56 builder = perfNote mode <> stateToBuilder state <> toMainExports mode rootMap
57 in
58 Some name names builder
61addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
62addMain mode graph home _ state =
63 addGlobal mode graph state (Opt.Global home "main")
66perfNote :: Mode.Mode -> B.Builder
67perfNote mode =
68 case mode of
69 Mode.Prod _ _ ->
70 ""
72 Mode.Dev _ Nothing ->
73 "console.warn('Compiled in DEV mode. Follow the advice at "
74 <> B.stringUtf8 (D.makeNakedLink "optimize")
75 <> " for better performance and smaller assets.');"
77 Mode.Dev _ (Just _) ->
78 "console.warn('Compiled in DEBUG mode. Follow the advice at "
79 <> B.stringUtf8 (D.makeNakedLink "optimize")
80 <> " for better performance and smaller assets.');"
84-- GENERATE FOR REPL
87generateForRepl :: Bool -> L.Localizer -> Opt.Graph -> I.Interface -> ModuleName.Canonical -> Name.Name -> B.Builder
88generateForRepl ansi localizer (Opt.Graph _ graph _) iface home name =
89 let
90 mode = Mode.dev Mode.Client
91 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
92 evalState = addGlobal mode graph debugState (Opt.Global home name)
93 in
94 stateToBuilder evalState
95 <>
96 print ansi localizer home name (I._types iface ! name)
99print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
100print ansi localizer home name (Can.Forall _ tipe) =
101 let
102 value = JsName.toBuilder (JsName.fromGlobal home name)
103 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
104 tipeDoc = RT.canToDoc localizer RT.None tipe
105 bool = if ansi then "true" else "false"
106 in
107 "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
108 \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
109 \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
110 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
111 \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
112 \} else {\n\
113 \ _print(' : ' + _type);\n\
114 \}\n"
118-- GRAPH TRAVERSAL STATE
121data State =
122 State
123 { _revKernels :: [B.Builder]
124 , _revBuilders :: [B.Builder]
125 , _seenGlobals :: Set.Set Opt.Global
126 }
129emptyState :: State
130emptyState =
131 State mempty [] Set.empty
134stateToBuilder :: State -> B.Builder
135stateToBuilder (State revKernels revBuilders _) =
136 prependBuilders revKernels (prependBuilders revBuilders mempty)
139prependBuilders :: [B.Builder] -> B.Builder -> B.Builder
140prependBuilders revBuilders monolith =
141 List.foldl' (\m b -> b <> m) monolith revBuilders
145-- ADD DEPENDENCIES
148type Graph = Map.Map Opt.Global Opt.Node
151addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
152addGlobal mode graph state@(State revKernels builders seen) global =
153 if Set.member global seen then
154 state
155 else
156 addGlobalHelp mode graph global $
157 State revKernels builders (Set.insert global seen)
160addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
161addGlobalHelp mode graph global state =
162 let
163 addDeps deps someState =
164 Set.foldl' (addGlobal mode graph) someState deps
165 in
166 case graph ! global of
167 Opt.Define expr deps ->
168 addStmt (addDeps deps state) (
169 var global (Expr.generate mode expr)
170 )
172 Opt.DefineTailFunc argNames body deps ->
173 addStmt (addDeps deps state) (
174 let (Opt.Global _ name) = global in
175 var global (Expr.generateTailDef mode name argNames body)
176 )
178 Opt.Ctor index arity ->
179 addStmt state (
180 var global (Expr.generateCtor mode global index arity)
181 )
183 Opt.Link linkedGlobal ->
184 addGlobal mode graph state linkedGlobal
186 Opt.Cycle names values functions deps ->
187 addStmt (addDeps deps state) (
188 generateCycle mode global names values functions
189 )
191 Opt.Manager effectsType ->
192 generateManager mode graph global effectsType state
194 Opt.Kernel chunks deps ->
195 if isDebugger global && not (Mode.isDebug mode) then
196 state
197 else
198 addKernel (addDeps deps state) (generateKernel mode chunks)
200 Opt.Enum index ->
201 addStmt state (
202 generateEnum mode global index
203 )
205 Opt.Box ->
206 addStmt (addGlobal mode graph state identity) (
207 generateBox mode global
208 )
210 Opt.PortIncoming decoder deps ->
211 addStmt (addDeps deps state) (
212 generatePort mode global "incomingPort" decoder
213 )
215 Opt.PortOutgoing encoder deps ->
216 addStmt (addDeps deps state) (
217 generatePort mode global "outgoingPort" encoder
218 )
221addStmt :: State -> JS.Stmt -> State
222addStmt state stmt =
223 addBuilder state (JS.stmtToBuilder stmt)
226addBuilder :: State -> B.Builder -> State
227addBuilder (State revKernels revBuilders seen) builder =
228 State revKernels (builder:revBuilders) seen
231addKernel :: State -> B.Builder -> State
232addKernel (State revKernels revBuilders seen) kernel =
233 State (kernel:revKernels) revBuilders seen
236var :: Opt.Global -> Expr.Code -> JS.Stmt
237var (Opt.Global home name) code =
238 JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]
241isDebugger :: Opt.Global -> Bool
242isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
243 home == Name.debugger
247-- GENERATE CYCLES
250generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
251generateCycle mode (Opt.Global home _) names values functions =
252 JS.Block
253 [ JS.Block $ map (generateCycleFunc mode home) functions
254 , JS.Block $ map (generateSafeCycle mode home) values
255 , case map (generateRealCycle home) values of
256 [] ->
257 JS.EmptyStmt
259 realBlock@(_:_) ->
260 case mode of
261 Mode.Prod _ _ ->
262 JS.Block realBlock
264 Mode.Dev _ _ ->
265 JS.Try (JS.Block realBlock) JsName.dollar $ JS.Throw $ JS.String $
266 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
267 <> drawCycle names
268 <> "\\n\\nThese errors are very tricky, so read "
269 <> B.stringUtf8 (D.makeNakedLink "halting-problem")
270 <> " to learn how to fix it!"
271 ]
274generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
275generateCycleFunc mode home def =
276 case def of
277 Opt.Def name expr ->
278 JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
280 Opt.TailDef name args expr ->
281 JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
284generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
285generateSafeCycle mode home (name, expr) =
286 JS.FunctionStmt (JsName.fromCycle home name) [] $
287 Expr.codeToStmtList (Expr.generate mode expr)
290generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt
291generateRealCycle home (name, _) =
292 let
293 safeName = JsName.fromCycle home name
294 realName = JsName.fromGlobal home name
295 in
296 JS.Block
297 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
298 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
299 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
300 ]
303drawCycle :: [Name.Name] -> B.Builder
304drawCycle names =
305 let
306 topLine = "\\n ┌─────┐"
307 nameLine name = "\\n │ " <> Name.toBuilder name
308 midLine = "\\n │ ↓"
309 bottomLine = "\\n └─────┘"
310 in
311 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
315-- GENERATE KERNEL
318generateKernel :: Mode.Mode -> [K.Chunk] -> B.Builder
319generateKernel mode chunks =
320 List.foldr (addChunk mode) mempty chunks
323addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
324addChunk mode chunk builder =
325 case chunk of
326 K.JS javascript ->
327 Utf8.toBuilder javascript <> builder
329 K.ElmVar home name ->
330 JsName.toBuilder (JsName.fromGlobal home name) <> builder
332 K.JsVar home name ->
333 JsName.toBuilder (JsName.fromKernel home name) <> builder
335 K.ElmField name ->
336 JsName.toBuilder (Expr.generateField mode name) <> builder
338 K.JsField int ->
339 JsName.toBuilder (JsName.fromInt int) <> builder
341 K.JsEnum int ->
342 B.intDec int <> builder
344 K.Debug ->
345 case mode of
346 Mode.Dev _ _ ->
347 builder
349 Mode.Prod _ _ ->
350 "_UNUSED" <> builder
352 K.Prod ->
353 case mode of
354 Mode.Dev _ _ ->
355 "_UNUSED" <> builder
357 Mode.Prod _ _ ->
358 builder
362-- GENERATE ENUM
365generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
366generateEnum mode global@(Opt.Global home name) index =
367 let
368 definition =
369 case mode of
370 Mode.Dev _ _ ->
371 Expr.codeToExpr (Expr.generateCtor mode global index 0)
373 Mode.Prod _ _ ->
374 JS.Int (Index.toMachine index)
375 in
376 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
380-- GENERATE BOX
383generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
384generateBox mode global@(Opt.Global home name) =
385 let
386 definition =
387 case mode of
388 Mode.Dev _ _ ->
389 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
391 Mode.Prod _ _ ->
392 JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
393 in
394 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
397{-# NOINLINE identity #-}
398identity :: Opt.Global
399identity =
400 Opt.Global ModuleName.basics Name.identity
404-- GENERATE PORTS
407generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
408generatePort mode (Opt.Global home name) makePort converter =
409 let
410 definition =
411 JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
412 [ JS.String (Name.toBuilder name)
413 , Expr.codeToExpr (Expr.generate mode converter)
414 ]
415 in
416 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
420-- GENERATE MANAGER
423generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
424generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
425 let
426 managerLVar =
427 JS.LBracket
428 (JS.Ref (JsName.fromKernel Name.platform "effectManagers"))
429 (JS.String (Name.toBuilder moduleName))
431 (deps, args, stmts) =
432 generateManagerHelp home effectsType
434 createManager =
435 JS.ExprStmt $ JS.Assign managerLVar $
436 JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args
437 in
438 addStmt (List.foldl' (addGlobal mode graph) state deps) $
439 JS.Block (createManager : stmts)
442generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
443generateLeaf home@(ModuleName.Canonical _ moduleName) name =
444 let
445 definition =
446 JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
447 in
448 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
451{-# NOINLINE leaf #-}
452leaf :: JS.Expr
453leaf =
454 JS.Ref (JsName.fromKernel Name.platform "leaf")
457generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
458generateManagerHelp home effectsType =
459 let
460 dep name = Opt.Global home name
461 ref name = JS.Ref (JsName.fromGlobal home name)
462 in
463 case effectsType of
464 Opt.Cmd ->
465 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
466 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
467 , [ generateLeaf home "command" ]
468 )
470 Opt.Sub ->
471 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
472 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
473 , [ generateLeaf home "subscription" ]
474 )
476 Opt.Fx ->
477 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
478 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
479 , [ generateLeaf home "command"
480 , generateLeaf home "subscription"
481 ]
482 )
486-- MAIN EXPORTS
489toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
490toMainExports mode mains =
491 let
492 export = JsName.fromKernel Name.platform "export"
493 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
494 in
495 JsName.toBuilder export <> "(" <> exports <> ");"
498generateExports :: Mode.Mode -> Trie -> B.Builder
499generateExports mode (Trie maybeMain subs) =
500 let
501 starter end =
502 case maybeMain of
503 Nothing ->
504 "{"
506 Just (home, main) ->
507 "{'init':"
508 <> JS.exprToBuilder (Expr.generateMain mode home main)
509 <> end
510 in
511 case Map.toList subs of
512 [] ->
513 starter "" <> "}"
515 (name, subTrie) : otherSubTries ->
516 starter "," <>
517 "'" <> Utf8.toBuilder name <> "':"
518 <> generateExports mode subTrie
519 <> List.foldl' (addSubTrie mode) "}" otherSubTries
522addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder
523addSubTrie mode end (name, trie) =
524 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
528-- BUILD TRIES
531data Trie =
532 Trie
533 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
534 , _subs :: Map.Map Utf8.String Trie
535 }
538emptyTrie :: Trie
539emptyTrie =
540 Trie Nothing Map.empty
543addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
544addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
545 let
546 segments =
547 Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)
548 in
549 merge trie $ segmentsToTrie home segments main
552segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie
553segmentsToTrie home segments main =
554 case segments of
555 [] ->
556 Trie (Just (home, main)) Map.empty
558 segment : otherSegments ->
559 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
562merge :: Trie -> Trie -> Trie
563merge (Trie main1 subs1) (Trie main2 subs2) =
564 Trie
565 (checkedMerge main1 main2)
566 (Map.unionWith merge subs1 subs2)
569checkedMerge :: Maybe a -> Maybe a -> Maybe a
570checkedMerge a b =
571 case (a, b) of
572 (Nothing, main) ->
573 main
575 (main, Nothing) ->
576 main
578 (Just _, Just _) ->
579 error "cannot have two modules with the same name"