git.iko.soy/elk
on 7dbdaae help sign in
elk/compiler/src/Generate/JavaScript.hs
533 lines 14 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 https://elm-lang.org/0.19.0/optimize for better performance and smaller assets.');"
76 Mode.Dev _ (Just _) ->
77 "console.warn('Compiled in DEBUG mode. Follow the advice at https://elm-lang.org/0.19.0/optimize for better performance and smaller assets.');"
81-- GENERATE FOR REPL
84generateForRepl :: Bool -> L.Localizer -> Opt.Graph -> I.Interface -> ModuleName.Canonical -> N.Name -> B.Builder
85generateForRepl ansi localizer (Opt.Graph _ graph _) iface home name =
86 let
87 mode = Mode.dev Mode.Client
88 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
89 evalState = addGlobal mode graph debugState (Opt.Global home name)
90 in
91 stateToBuilder evalState
92 <>
93 print ansi localizer home name (I._types iface ! name)
96print :: Bool -> L.Localizer -> ModuleName.Canonical -> N.Name -> Can.Annotation -> B.Builder
97print ansi localizer home name (Can.Forall _ tipe) =
98 let
99 value = Name.toBuilder (Name.fromGlobal home name)
100 toString = Name.toBuilder (Name.fromKernel N.debug "toAnsiString")
101 tipeDoc = RT.canToDoc localizer RT.None tipe
102 bool = if ansi then "true" else "false"
103 in
104 "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
105 \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
106 \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
107 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
108 \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
109 \} else {\n\
110 \ _print(' : ' + _type);\n\
111 \}\n"
115-- GRAPH TRAVERSAL STATE
118data State =
119 State
120 { _revKernels :: [B.Builder]
121 , _revBuilders :: [B.Builder]
122 , _seenGlobals :: Set.Set Opt.Global
123 }
126emptyState :: State
127emptyState =
128 State mempty [] Set.empty
131stateToBuilder :: State -> B.Builder
132stateToBuilder (State revKernels revBuilders _) =
133 prependBuilders revKernels (prependBuilders revBuilders mempty)
136prependBuilders :: [B.Builder] -> B.Builder -> B.Builder
137prependBuilders revBuilders monolith =
138 List.foldl' (\m b -> b <> m) monolith revBuilders
142-- ADD DEPENDENCIES
145type Graph = Map.Map Opt.Global Opt.Node
148addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
149addGlobal mode graph state@(State revKernels builders seen) global =
150 if Set.member global seen then
151 state
152 else
153 addGlobalHelp mode graph global $
154 State revKernels builders (Set.insert global seen)
157addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
158addGlobalHelp mode graph global state =
159 let
160 addDeps deps someState =
161 Set.foldl' (addGlobal mode graph) someState deps
162 in
163 case graph ! global of
164 Opt.Define expr deps ->
165 addStmt (addDeps deps state) (
166 var global (Expr.generate mode expr)
167 )
169 Opt.DefineTailFunc argNames body deps ->
170 addStmt (addDeps deps state) (
171 let (Opt.Global _ name) = global in
172 var global (Expr.generateTailDef mode name argNames body)
173 )
175 Opt.Ctor index arity ->
176 addStmt state (
177 var global (Expr.generateCtor mode global index arity)
178 )
180 Opt.Link linkedGlobal ->
181 addGlobal mode graph state linkedGlobal
183 Opt.Cycle cycle deps ->
184 addStmt (addDeps deps state) (
185 generateCycle mode global cycle
186 )
188 Opt.Manager effectsType ->
189 generateManager mode graph global effectsType state
191 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
192 if isDebugger global && not (Mode.isDebug mode) then
193 state
194 else
195 case maybeServer of
196 Just (Opt.KContent serverChunks serverDeps) | Mode.isServer mode ->
197 addKernel (addDeps serverDeps state) (generateKernel mode serverChunks)
199 _ ->
200 addKernel (addDeps clientDeps state) (generateKernel mode clientChunks)
202 Opt.Enum index ->
203 addStmt state (
204 generateEnum mode global index
205 )
207 Opt.Box ->
208 addStmt state (
209 generateBox mode global
210 )
212 Opt.PortIncoming decoder deps ->
213 addStmt (addDeps deps state) (
214 generatePort mode global "incomingPort" decoder
215 )
217 Opt.PortOutgoing encoder deps ->
218 addStmt (addDeps deps state) (
219 generatePort mode global "outgoingPort" encoder
220 )
223addStmt :: State -> JS.Stmt -> State
224addStmt state stmt =
225 addBuilder state (JS.stmtToBuilder stmt)
228addBuilder :: State -> B.Builder -> State
229addBuilder (State revKernels revBuilders seen) builder =
230 State revKernels (builder:revBuilders) seen
233addKernel :: State -> B.Builder -> State
234addKernel (State revKernels revBuilders seen) kernel =
235 State (kernel:revKernels) revBuilders seen
238var :: Opt.Global -> Expr.Code -> JS.Stmt
239var (Opt.Global home name) code =
240 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
243isDebugger :: Opt.Global -> Bool
244isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
245 home == N.debugger
249-- GENERATE CYCLES
252generateCycle :: Mode.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
253generateCycle mode (Opt.Global home _) cycle =
254 let
255 safeDefs = map (generateSafeCycle mode home) cycle
256 realDefs = map (generateRealCycle home) cycle
257 in
258 JS.Block (safeDefs ++ realDefs)
261generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
262generateSafeCycle mode home (name, expr) =
263 JS.FunctionStmt (Name.fromCycle home name) [] $
264 Expr.codeToStmtList (Expr.generate mode expr)
267generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
268generateRealCycle home (name, _) =
269 let
270 safeName = Name.fromCycle home name
271 realName = Name.fromGlobal home name
272 in
273 JS.Block
274 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
275 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
276 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
277 ]
281-- GENERATE KERNEL
284generateKernel :: Mode.Mode -> [Opt.KChunk] -> B.Builder
285generateKernel mode chunks =
286 List.foldl' (addChunk mode) mempty chunks
289addChunk :: Mode.Mode -> B.Builder -> Opt.KChunk -> B.Builder
290addChunk mode builder chunk =
291 case chunk of
292 Opt.JS javascript ->
293 B.byteString javascript <> builder
295 Opt.ElmVar home name ->
296 Name.toBuilder (Name.fromGlobal home name) <> builder
298 Opt.JsVar home name ->
299 Name.toBuilder (Name.fromKernel home name) <> builder
301 Opt.ElmField name ->
302 Name.toBuilder (Expr.generateField mode name) <> builder
304 Opt.JsField int ->
305 Name.toBuilder (Name.fromInt int) <> builder
307 Opt.JsEnum int ->
308 B.intDec int <> builder
310 Opt.Debug ->
311 case mode of
312 Mode.Dev _ _ ->
313 builder
315 Mode.Prod _ _ ->
316 "_UNUSED" <> builder
318 Opt.Prod ->
319 case mode of
320 Mode.Dev _ _ ->
321 "_UNUSED" <> builder
323 Mode.Prod _ _ ->
324 builder
328-- GENERATE ENUM
331generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
332generateEnum mode global@(Opt.Global home name) index =
333 let
334 definition =
335 case mode of
336 Mode.Dev _ _ ->
337 Expr.codeToExpr (Expr.generateCtor mode global index 0)
339 Mode.Prod _ _ ->
340 JS.Int (Index.toMachine index)
341 in
342 JS.Var [ (Name.fromGlobal home name, Just definition) ]
346-- GENERATE BOX
349generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
350generateBox mode global@(Opt.Global home name) =
351 let
352 definition =
353 case mode of
354 Mode.Dev _ _ ->
355 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
357 Mode.Prod _ _ ->
358 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
359 in
360 JS.Var [ (Name.fromGlobal home name, Just definition) ]
364-- GENERATE PORTS
367generatePort :: Mode.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
368generatePort mode (Opt.Global home name) makePort converter =
369 let
370 definition =
371 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
372 [ JS.String (N.toBuilder name)
373 , Expr.codeToExpr (Expr.generate mode converter)
374 ]
375 in
376 JS.Var [ (Name.fromGlobal home name, Just definition) ]
380-- GENERATE MANAGER
383generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
384generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
385 let
386 managerLVar =
387 JS.LBracket
388 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
389 (JS.String (N.toBuilder moduleName))
391 (deps, args, stmts) =
392 generateManagerHelp home effectsType
394 createManager =
395 JS.ExprStmt $ JS.Assign managerLVar $
396 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
397 in
398 addStmt (List.foldl' (addGlobal mode graph) state deps) $
399 JS.Block (createManager : stmts)
402generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
403generateLeaf home@(ModuleName.Canonical _ moduleName) name =
404 let
405 definition =
406 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
407 in
408 JS.Var [ (Name.fromGlobal home name, Just definition) ]
411{-# NOINLINE leaf #-}
412leaf :: JS.Expr
413leaf =
414 JS.Ref (Name.fromKernel N.platform "leaf")
417generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
418generateManagerHelp home effectsType =
419 let
420 dep name = Opt.Global home name
421 ref name = JS.Ref (Name.fromGlobal home name)
422 in
423 case effectsType of
424 Opt.Cmd ->
425 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
426 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
427 , [ generateLeaf home "command" ]
428 )
430 Opt.Sub ->
431 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
432 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
433 , [ generateLeaf home "subscription" ]
434 )
436 Opt.Fx ->
437 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
438 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
439 , [ generateLeaf home "command"
440 , generateLeaf home "subscription"
441 ]
442 )
446-- MAIN EXPORTS
449toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
450toMainExports mode mains =
451 let
452 export = Name.fromKernel N.platform "export"
453 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
454 in
455 Name.toBuilder export <> "(" <> exports <> ");"
458generateExports :: Mode.Mode -> Trie -> B.Builder
459generateExports mode (Trie maybeMain subs) =
460 let
461 object =
462 case Map.toList subs of
463 [] ->
464 "{}"
466 (name, subTrie) : otherSubTries ->
467 "{'" <> Text.encodeUtf8Builder name <> "':"
468 <> generateExports mode subTrie
469 <> List.foldl' (addSubTrie mode) "}" otherSubTries
470 in
471 case maybeMain of
472 Nothing ->
473 object
475 Just (home, main) ->
476 let initialize = Expr.generateMain mode home main in
477 JS.exprToBuilder initialize <> "(" <> object <> ")"
480addSubTrie :: Mode.Mode -> B.Builder -> (Text.Text, Trie) -> B.Builder
481addSubTrie mode end (name, trie) =
482 ",'" <> Text.encodeUtf8Builder name <> "':" <> generateExports mode trie <> end
486-- BUILD TRIES
489data Trie =
490 Trie
491 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
492 , _subs :: Map.Map Text.Text Trie
493 }
496emptyTrie :: Trie
497emptyTrie =
498 Trie Nothing Map.empty
501addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
502addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
503 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
506segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
507segmentsToTrie home segments main =
508 case segments of
509 [] ->
510 Trie (Just (home, main)) Map.empty
512 segment : otherSegments ->
513 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
516merge :: Trie -> Trie -> Trie
517merge (Trie main1 subs1) (Trie main2 subs2) =
518 Trie
519 (checkedMerge main1 main2)
520 (Map.unionWith merge subs1 subs2)
523checkedMerge :: Maybe a -> Maybe a -> Maybe a
524checkedMerge a b =
525 case (a, b) of
526 (Nothing, main) ->
527 main
529 (main, Nothing) ->
530 main
532 (Just _, Just _) ->
533 error "cannot have two modules with the same name"