git.iko.soy/elk
on 6356535 help sign in
elk/compiler/src/Generate/JavaScript.hs
573 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.Set as Set
17import qualified Data.Text as Text
18import qualified Data.Text.Encoding as Text
20import qualified AST.Canonical as Can
21import qualified AST.Optimized as Opt
22import qualified AST.Module.Name as ModuleName
23import qualified Data.Index as Index
24import qualified Elm.Interface as I
25import qualified Elm.Name as N
26import qualified Generate.JavaScript.Builder as JS
27import qualified Generate.JavaScript.Expression as Expr
28import qualified Generate.JavaScript.Name as Name
29import qualified Generate.JavaScript.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 N.Name [N.Name] B.Builder
44generate :: Mode.Mode -> Opt.Graph -> [ModuleName.Canonical] -> Output
45generate mode (Opt.Graph mains graph _fields) 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 -> N.Name -> B.Builder
89generateForRepl ansi localizer (Opt.Graph _ graph _) iface home name =
90 let
91 mode = Mode.dev Mode.Client
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._types iface ! name)
100print :: Bool -> L.Localizer -> ModuleName.Canonical -> N.Name -> Can.Annotation -> B.Builder
101print ansi localizer home name (Can.Forall _ tipe) =
102 let
103 value = Name.toBuilder (Name.fromGlobal home name)
104 toString = Name.toBuilder (Name.fromKernel N.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 (Opt.KContent clientChunks clientDeps) maybeServer ->
196 if isDebugger global && not (Mode.isDebug mode) then
197 state
198 else
199 case maybeServer of
200 Just (Opt.KContent serverChunks serverDeps) | Mode.isServer mode ->
201 addKernel (addDeps serverDeps state) (generateKernel mode serverChunks)
203 _ ->
204 addKernel (addDeps clientDeps state) (generateKernel mode clientChunks)
206 Opt.Enum index ->
207 addStmt state (
208 generateEnum mode global index
209 )
211 Opt.Box ->
212 addStmt state (
213 generateBox mode global
214 )
216 Opt.PortIncoming decoder deps ->
217 addStmt (addDeps deps state) (
218 generatePort mode global "incomingPort" decoder
219 )
221 Opt.PortOutgoing encoder deps ->
222 addStmt (addDeps deps state) (
223 generatePort mode global "outgoingPort" encoder
224 )
227addStmt :: State -> JS.Stmt -> State
228addStmt state stmt =
229 addBuilder state (JS.stmtToBuilder stmt)
232addBuilder :: State -> B.Builder -> State
233addBuilder (State revKernels revBuilders seen) builder =
234 State revKernels (builder:revBuilders) seen
237addKernel :: State -> B.Builder -> State
238addKernel (State revKernels revBuilders seen) kernel =
239 State (kernel:revKernels) revBuilders seen
242var :: Opt.Global -> Expr.Code -> JS.Stmt
243var (Opt.Global home name) code =
244 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
247isDebugger :: Opt.Global -> Bool
248isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
249 home == N.debugger
253-- GENERATE CYCLES
256generateCycle :: Mode.Mode -> Opt.Global -> [N.Name] -> [(N.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
257generateCycle mode (Opt.Global home _) names values functions =
258 let
259 funcBlock = JS.Block $ map (generateCycleFunc mode home) functions
260 safeBlock = JS.Block $ map (generateSafeCycle mode home) values
261 realBlock = JS.Block $ map (generateRealCycle home) values
262 in
263 case mode of
264 Mode.Prod _ _ ->
265 JS.Block [ funcBlock, safeBlock, realBlock ]
267 Mode.Dev _ _ ->
268 let
269 tryRealBlock =
270 JS.Try realBlock Name.dollar $ JS.Throw $ JS.String $
271 "Some top-level definitions from `" <> N.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
272 <> drawCycle names
273 <> "\\n\\nThese errors are very tricky, so read "
274 <> B.stringUtf8 (D.makeNakedLink "halting-problem")
275 <> " to learn how to fix it!"
276 in
277 JS.Block [ funcBlock, safeBlock, tryRealBlock ]
280generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
281generateCycleFunc mode home def =
282 case def of
283 Opt.Def name expr ->
284 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
286 Opt.TailDef name args expr ->
287 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
290generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
291generateSafeCycle mode home (name, expr) =
292 JS.FunctionStmt (Name.fromCycle home name) [] $
293 Expr.codeToStmtList (Expr.generate mode expr)
296generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
297generateRealCycle home (name, _) =
298 let
299 safeName = Name.fromCycle home name
300 realName = Name.fromGlobal home name
301 in
302 JS.Block
303 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
304 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
305 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
306 ]
309drawCycle :: [N.Name] -> B.Builder
310drawCycle names =
311 let
312 topLine = "\\n ┌─────┐"
313 nameLine name = "\\n │ " <> N.toBuilder name
314 midLine = "\\n │ ↓"
315 bottomLine = "\\n └─────┘"
316 in
317 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
321-- GENERATE KERNEL
324generateKernel :: Mode.Mode -> [Opt.KChunk] -> B.Builder
325generateKernel mode chunks =
326 List.foldl' (addChunk mode) mempty chunks
329addChunk :: Mode.Mode -> B.Builder -> Opt.KChunk -> B.Builder
330addChunk mode builder chunk =
331 case chunk of
332 Opt.JS javascript ->
333 B.byteString javascript <> builder
335 Opt.ElmVar home name ->
336 Name.toBuilder (Name.fromGlobal home name) <> builder
338 Opt.JsVar home name ->
339 Name.toBuilder (Name.fromKernel home name) <> builder
341 Opt.ElmField name ->
342 Name.toBuilder (Expr.generateField mode name) <> builder
344 Opt.JsField int ->
345 Name.toBuilder (Name.fromInt int) <> builder
347 Opt.JsEnum int ->
348 B.intDec int <> builder
350 Opt.Debug ->
351 case mode of
352 Mode.Dev _ _ ->
353 builder
355 Mode.Prod _ _ ->
356 "_UNUSED" <> builder
358 Opt.Prod ->
359 case mode of
360 Mode.Dev _ _ ->
361 "_UNUSED" <> builder
363 Mode.Prod _ _ ->
364 builder
368-- GENERATE ENUM
371generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
372generateEnum mode global@(Opt.Global home name) index =
373 let
374 definition =
375 case mode of
376 Mode.Dev _ _ ->
377 Expr.codeToExpr (Expr.generateCtor mode global index 0)
379 Mode.Prod _ _ ->
380 JS.Int (Index.toMachine index)
381 in
382 JS.Var [ (Name.fromGlobal home name, Just definition) ]
386-- GENERATE BOX
389generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
390generateBox mode global@(Opt.Global home name) =
391 let
392 definition =
393 case mode of
394 Mode.Dev _ _ ->
395 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
397 Mode.Prod _ _ ->
398 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
399 in
400 JS.Var [ (Name.fromGlobal home name, Just definition) ]
404-- GENERATE PORTS
407generatePort :: Mode.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
408generatePort mode (Opt.Global home name) makePort converter =
409 let
410 definition =
411 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
412 [ JS.String (N.toBuilder name)
413 , Expr.codeToExpr (Expr.generate mode converter)
414 ]
415 in
416 JS.Var [ (Name.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 (Name.fromKernel N.platform "effectManagers"))
429 (JS.String (N.toBuilder moduleName))
431 (deps, args, stmts) =
432 generateManagerHelp home effectsType
434 createManager =
435 JS.ExprStmt $ JS.Assign managerLVar $
436 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
437 in
438 addStmt (List.foldl' (addGlobal mode graph) state deps) $
439 JS.Block (createManager : stmts)
442generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
443generateLeaf home@(ModuleName.Canonical _ moduleName) name =
444 let
445 definition =
446 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
447 in
448 JS.Var [ (Name.fromGlobal home name, Just definition) ]
451{-# NOINLINE leaf #-}
452leaf :: JS.Expr
453leaf =
454 JS.Ref (Name.fromKernel N.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 (Name.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 = Name.fromKernel N.platform "export"
493 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
494 in
495 Name.toBuilder export <> "(" <> exports <> ");"
498generateExports :: Mode.Mode -> Trie -> B.Builder
499generateExports mode (Trie maybeMain subs) =
500 let
501 object =
502 case Map.toList subs of
503 [] ->
504 "{}"
506 (name, subTrie) : otherSubTries ->
507 "{'" <> Text.encodeUtf8Builder name <> "':"
508 <> generateExports mode subTrie
509 <> List.foldl' (addSubTrie mode) "}" otherSubTries
510 in
511 case maybeMain of
512 Nothing ->
513 object
515 Just (home, main) ->
516 let initialize = Expr.generateMain mode home main in
517 JS.exprToBuilder initialize <> "(" <> object <> ")"
520addSubTrie :: Mode.Mode -> B.Builder -> (Text.Text, Trie) -> B.Builder
521addSubTrie mode end (name, trie) =
522 ",'" <> Text.encodeUtf8Builder name <> "':" <> generateExports mode trie <> end
526-- BUILD TRIES
529data Trie =
530 Trie
531 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
532 , _subs :: Map.Map Text.Text Trie
533 }
536emptyTrie :: Trie
537emptyTrie =
538 Trie Nothing Map.empty
541addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
542addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
543 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
546segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
547segmentsToTrie home segments main =
548 case segments of
549 [] ->
550 Trie (Just (home, main)) Map.empty
552 segment : otherSegments ->
553 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
556merge :: Trie -> Trie -> Trie
557merge (Trie main1 subs1) (Trie main2 subs2) =
558 Trie
559 (checkedMerge main1 main2)
560 (Map.unionWith merge subs1 subs2)
563checkedMerge :: Maybe a -> Maybe a -> Maybe a
564checkedMerge a b =
565 case (a, b) of
566 (Nothing, main) ->
567 main
569 (main, Nothing) ->
570 main
572 (Just _, Just _) ->
573 error "cannot have two modules with the same name"