git.iko.soy/elk
on 436f495 help sign in
elk/compiler/src/Generate/JavaScript.hs
580 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.Mode as Mode
30import qualified Reporting.Doc as D
31import qualified Reporting.Render.Type as RT
32import qualified Reporting.Render.Type.Localizer as L
36-- GENERATE MAINS
39data Output
40 = None
41 | Some Name.Name [Name.Name] B.Builder
44generate :: Mode.Mode -> Opt.Graph -> [ModuleName.Canonical] -> Output
45generate mode (Opt.Graph mains graph _) roots =
46 let
47 rootSet = Set.fromList roots
48 rootMap = Map.restrictKeys mains rootSet
49 in
50 case map ModuleName._module (Map.keys rootMap) of
51 [] ->
52 None
54 name:names ->
55 let
56 state = Map.foldrWithKey (addMain mode graph) emptyState rootMap
57 builder = perfNote mode <> stateToBuilder state <> toMainExports mode rootMap
58 in
59 Some name names builder
62addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
63addMain mode graph home _ state =
64 addGlobal mode graph state (Opt.Global home "main")
67perfNote :: Mode.Mode -> B.Builder
68perfNote mode =
69 case mode of
70 Mode.Prod _ ->
71 ""
73 Mode.Dev Nothing ->
74 "console.warn('Compiled in DEV mode. Follow the advice at "
75 <> B.stringUtf8 (D.makeNakedLink "optimize")
76 <> " for better performance and smaller assets.');"
78 Mode.Dev (Just _) ->
79 "console.warn('Compiled in DEBUG mode. Follow the advice at "
80 <> B.stringUtf8 (D.makeNakedLink "optimize")
81 <> " for better performance and smaller assets.');"
85-- GENERATE FOR REPL
88generateForRepl :: Bool -> L.Localizer -> Opt.Graph -> I.Interface -> ModuleName.Canonical -> Name.Name -> B.Builder
89generateForRepl ansi localizer (Opt.Graph _ graph _) iface home name =
90 let
91 mode = Mode.Dev Nothing
92 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
93 evalState = addGlobal mode graph debugState (Opt.Global home name)
94 in
95 stateToBuilder evalState
96 <>
97 print ansi localizer home name (I._values iface ! name)
100print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
101print ansi localizer home name (Can.Forall _ tipe) =
102 let
103 value = JsName.toBuilder (JsName.fromGlobal home name)
104 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
105 tipeDoc = RT.canToDoc localizer RT.None tipe
106 bool = if ansi then "true" else "false"
107 in
108 "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
109 \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
110 \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
111 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
112 \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
113 \} else {\n\
114 \ _print(' : ' + _type);\n\
115 \}\n"
119-- GRAPH TRAVERSAL STATE
122data State =
123 State
124 { _revKernels :: [B.Builder]
125 , _revBuilders :: [B.Builder]
126 , _seenGlobals :: Set.Set Opt.Global
127 }
130emptyState :: State
131emptyState =
132 State mempty [] Set.empty
135stateToBuilder :: State -> B.Builder
136stateToBuilder (State revKernels revBuilders _) =
137 prependBuilders revKernels (prependBuilders revBuilders mempty)
140prependBuilders :: [B.Builder] -> B.Builder -> B.Builder
141prependBuilders revBuilders monolith =
142 List.foldl' (\m b -> b <> m) monolith revBuilders
146-- ADD DEPENDENCIES
149type Graph = Map.Map Opt.Global Opt.Node
152addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
153addGlobal mode graph state@(State revKernels builders seen) global =
154 if Set.member global seen then
155 state
156 else
157 addGlobalHelp mode graph global $
158 State revKernels builders (Set.insert global seen)
161addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
162addGlobalHelp mode graph global state =
163 let
164 addDeps deps someState =
165 Set.foldl' (addGlobal mode graph) someState deps
166 in
167 case graph ! global of
168 Opt.Define expr deps ->
169 addStmt (addDeps deps state) (
170 var global (Expr.generate mode expr)
171 )
173 Opt.DefineTailFunc argNames body deps ->
174 addStmt (addDeps deps state) (
175 let (Opt.Global _ name) = global in
176 var global (Expr.generateTailDef mode name argNames body)
177 )
179 Opt.Ctor index arity ->
180 addStmt state (
181 var global (Expr.generateCtor mode global index arity)
182 )
184 Opt.Link linkedGlobal ->
185 addGlobal mode graph state linkedGlobal
187 Opt.Cycle names values functions deps ->
188 addStmt (addDeps deps state) (
189 generateCycle mode global names values functions
190 )
192 Opt.Manager effectsType ->
193 generateManager mode graph global effectsType state
195 Opt.Kernel chunks deps ->
196 if isDebugger global && not (Mode.isDebug mode) then
197 state
198 else
199 addKernel (addDeps deps state) (generateKernel mode chunks)
201 Opt.Enum index ->
202 addStmt state (
203 generateEnum mode global index
204 )
206 Opt.Box ->
207 addStmt (addGlobal mode graph state identity) (
208 generateBox mode global
209 )
211 Opt.PortIncoming decoder deps ->
212 addStmt (addDeps deps state) (
213 generatePort mode global "incomingPort" decoder
214 )
216 Opt.PortOutgoing encoder deps ->
217 addStmt (addDeps deps state) (
218 generatePort mode global "outgoingPort" encoder
219 )
222addStmt :: State -> JS.Stmt -> State
223addStmt state stmt =
224 addBuilder state (JS.stmtToBuilder stmt)
227addBuilder :: State -> B.Builder -> State
228addBuilder (State revKernels revBuilders seen) builder =
229 State revKernels (builder:revBuilders) seen
232addKernel :: State -> B.Builder -> State
233addKernel (State revKernels revBuilders seen) kernel =
234 State (kernel:revKernels) revBuilders seen
237var :: Opt.Global -> Expr.Code -> JS.Stmt
238var (Opt.Global home name) code =
239 JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]
242isDebugger :: Opt.Global -> Bool
243isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
244 home == Name.debugger
248-- GENERATE CYCLES
251generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
252generateCycle mode (Opt.Global home _) names values functions =
253 JS.Block
254 [ JS.Block $ map (generateCycleFunc mode home) functions
255 , JS.Block $ map (generateSafeCycle mode home) values
256 , case map (generateRealCycle home) values of
257 [] ->
258 JS.EmptyStmt
260 realBlock@(_:_) ->
261 case mode of
262 Mode.Prod _ ->
263 JS.Block realBlock
265 Mode.Dev _ ->
266 JS.Try (JS.Block realBlock) JsName.dollar $ JS.Throw $ JS.String $
267 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
268 <> drawCycle names
269 <> "\\n\\nThese errors are very tricky, so read "
270 <> B.stringUtf8 (D.makeNakedLink "halting-problem")
271 <> " to learn how to fix it!"
272 ]
275generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
276generateCycleFunc mode home def =
277 case def of
278 Opt.Def name expr ->
279 JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
281 Opt.TailDef name args expr ->
282 JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
285generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
286generateSafeCycle mode home (name, expr) =
287 JS.FunctionStmt (JsName.fromCycle home name) [] $
288 Expr.codeToStmtList (Expr.generate mode expr)
291generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt
292generateRealCycle home (name, _) =
293 let
294 safeName = JsName.fromCycle home name
295 realName = JsName.fromGlobal home name
296 in
297 JS.Block
298 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
299 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
300 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
301 ]
304drawCycle :: [Name.Name] -> B.Builder
305drawCycle names =
306 let
307 topLine = "\\n ┌─────┐"
308 nameLine name = "\\n │ " <> Name.toBuilder name
309 midLine = "\\n │ ↓"
310 bottomLine = "\\n └─────┘"
311 in
312 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
316-- GENERATE KERNEL
319generateKernel :: Mode.Mode -> [K.Chunk] -> B.Builder
320generateKernel mode chunks =
321 List.foldr (addChunk mode) mempty chunks
324addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
325addChunk mode chunk builder =
326 case chunk of
327 K.JS javascript ->
328 Utf8.toBuilder javascript <> builder
330 K.ElmVar home name ->
331 JsName.toBuilder (JsName.fromGlobal home name) <> builder
333 K.JsVar home name ->
334 JsName.toBuilder (JsName.fromKernel home name) <> builder
336 K.ElmField name ->
337 JsName.toBuilder (Expr.generateField mode name) <> builder
339 K.JsField int ->
340 JsName.toBuilder (JsName.fromInt int) <> builder
342 K.JsEnum int ->
343 B.intDec int <> builder
345 K.Debug ->
346 case mode of
347 Mode.Dev _ ->
348 builder
350 Mode.Prod _ ->
351 "_UNUSED" <> builder
353 K.Prod ->
354 case mode of
355 Mode.Dev _ ->
356 "_UNUSED" <> builder
358 Mode.Prod _ ->
359 builder
363-- GENERATE ENUM
366generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
367generateEnum mode global@(Opt.Global home name) index =
368 let
369 definition =
370 case mode of
371 Mode.Dev _ ->
372 Expr.codeToExpr (Expr.generateCtor mode global index 0)
374 Mode.Prod _ ->
375 JS.Int (Index.toMachine index)
376 in
377 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
381-- GENERATE BOX
384generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
385generateBox mode global@(Opt.Global home name) =
386 let
387 definition =
388 case mode of
389 Mode.Dev _ ->
390 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
392 Mode.Prod _ ->
393 JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
394 in
395 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
398{-# NOINLINE identity #-}
399identity :: Opt.Global
400identity =
401 Opt.Global ModuleName.basics Name.identity
405-- GENERATE PORTS
408generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
409generatePort mode (Opt.Global home name) makePort converter =
410 let
411 definition =
412 JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
413 [ JS.String (Name.toBuilder name)
414 , Expr.codeToExpr (Expr.generate mode converter)
415 ]
416 in
417 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
421-- GENERATE MANAGER
424generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
425generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
426 let
427 managerLVar =
428 JS.LBracket
429 (JS.Ref (JsName.fromKernel Name.platform "effectManagers"))
430 (JS.String (Name.toBuilder moduleName))
432 (deps, args, stmts) =
433 generateManagerHelp home effectsType
435 createManager =
436 JS.ExprStmt $ JS.Assign managerLVar $
437 JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args
438 in
439 addStmt (List.foldl' (addGlobal mode graph) state deps) $
440 JS.Block (createManager : stmts)
443generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
444generateLeaf home@(ModuleName.Canonical _ moduleName) name =
445 let
446 definition =
447 JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
448 in
449 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
452{-# NOINLINE leaf #-}
453leaf :: JS.Expr
454leaf =
455 JS.Ref (JsName.fromKernel Name.platform "leaf")
458generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
459generateManagerHelp home effectsType =
460 let
461 dep name = Opt.Global home name
462 ref name = JS.Ref (JsName.fromGlobal home name)
463 in
464 case effectsType of
465 Opt.Cmd ->
466 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
467 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
468 , [ generateLeaf home "command" ]
469 )
471 Opt.Sub ->
472 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
473 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
474 , [ generateLeaf home "subscription" ]
475 )
477 Opt.Fx ->
478 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
479 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
480 , [ generateLeaf home "command"
481 , generateLeaf home "subscription"
482 ]
483 )
487-- MAIN EXPORTS
490toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
491toMainExports mode mains =
492 let
493 export = JsName.fromKernel Name.platform "export"
494 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
495 in
496 JsName.toBuilder export <> "(" <> exports <> ");"
499generateExports :: Mode.Mode -> Trie -> B.Builder
500generateExports mode (Trie maybeMain subs) =
501 let
502 starter end =
503 case maybeMain of
504 Nothing ->
505 "{"
507 Just (home, main) ->
508 "{'init':"
509 <> JS.exprToBuilder (Expr.generateMain mode home main)
510 <> end
511 in
512 case Map.toList subs of
513 [] ->
514 starter "" <> "}"
516 (name, subTrie) : otherSubTries ->
517 starter "," <>
518 "'" <> Utf8.toBuilder name <> "':"
519 <> generateExports mode subTrie
520 <> List.foldl' (addSubTrie mode) "}" otherSubTries
523addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder
524addSubTrie mode end (name, trie) =
525 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
529-- BUILD TRIES
532data Trie =
533 Trie
534 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
535 , _subs :: Map.Map Utf8.String Trie
536 }
539emptyTrie :: Trie
540emptyTrie =
541 Trie Nothing Map.empty
544addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
545addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
546 let
547 segments =
548 Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)
549 in
550 merge trie $ segmentsToTrie home segments main
553segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie
554segmentsToTrie home segments main =
555 case segments of
556 [] ->
557 Trie (Just (home, main)) Map.empty
559 segment : otherSegments ->
560 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
563merge :: Trie -> Trie -> Trie
564merge (Trie main1 subs1) (Trie main2 subs2) =
565 Trie
566 (checkedMerge main1 main2)
567 (Map.unionWith merge subs1 subs2)
570checkedMerge :: Maybe a -> Maybe a -> Maybe a
571checkedMerge a b =
572 case (a, b) of
573 (Nothing, main) ->
574 main
576 (main, Nothing) ->
577 main
579 (Just _, Just _) ->
580 error "cannot have two modules with the same name"