git.iko.soy/elk
on 4258527 help sign in
elk/compiler/src/Generate/JavaScript.hs
548 lines 15 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 values functions deps ->
188 addStmt (addDeps deps state) (
189 generateCycle mode global 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, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
257generateCycle mode (Opt.Global home _) values functions =
258 let
259 funcDefs = map (generateCycleFunc mode home) functions
260 safeDefs = map (generateSafeCycle mode home) values
261 realDefs = map (generateRealCycle home) values
262 in
263 JS.Block (funcDefs ++ safeDefs ++ realDefs)
266generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
267generateCycleFunc mode home def =
268 case def of
269 Opt.Def name expr ->
270 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
272 Opt.TailDef name args expr ->
273 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
276generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
277generateSafeCycle mode home (name, expr) =
278 JS.FunctionStmt (Name.fromCycle home name) [] $
279 Expr.codeToStmtList (Expr.generate mode expr)
282generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
283generateRealCycle home (name, _) =
284 let
285 safeName = Name.fromCycle home name
286 realName = Name.fromGlobal home name
287 in
288 JS.Block
289 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
290 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
291 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
292 ]
296-- GENERATE KERNEL
299generateKernel :: Mode.Mode -> [Opt.KChunk] -> B.Builder
300generateKernel mode chunks =
301 List.foldl' (addChunk mode) mempty chunks
304addChunk :: Mode.Mode -> B.Builder -> Opt.KChunk -> B.Builder
305addChunk mode builder chunk =
306 case chunk of
307 Opt.JS javascript ->
308 B.byteString javascript <> builder
310 Opt.ElmVar home name ->
311 Name.toBuilder (Name.fromGlobal home name) <> builder
313 Opt.JsVar home name ->
314 Name.toBuilder (Name.fromKernel home name) <> builder
316 Opt.ElmField name ->
317 Name.toBuilder (Expr.generateField mode name) <> builder
319 Opt.JsField int ->
320 Name.toBuilder (Name.fromInt int) <> builder
322 Opt.JsEnum int ->
323 B.intDec int <> builder
325 Opt.Debug ->
326 case mode of
327 Mode.Dev _ _ ->
328 builder
330 Mode.Prod _ _ ->
331 "_UNUSED" <> builder
333 Opt.Prod ->
334 case mode of
335 Mode.Dev _ _ ->
336 "_UNUSED" <> builder
338 Mode.Prod _ _ ->
339 builder
343-- GENERATE ENUM
346generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
347generateEnum mode global@(Opt.Global home name) index =
348 let
349 definition =
350 case mode of
351 Mode.Dev _ _ ->
352 Expr.codeToExpr (Expr.generateCtor mode global index 0)
354 Mode.Prod _ _ ->
355 JS.Int (Index.toMachine index)
356 in
357 JS.Var [ (Name.fromGlobal home name, Just definition) ]
361-- GENERATE BOX
364generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
365generateBox mode global@(Opt.Global home name) =
366 let
367 definition =
368 case mode of
369 Mode.Dev _ _ ->
370 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
372 Mode.Prod _ _ ->
373 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
374 in
375 JS.Var [ (Name.fromGlobal home name, Just definition) ]
379-- GENERATE PORTS
382generatePort :: Mode.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
383generatePort mode (Opt.Global home name) makePort converter =
384 let
385 definition =
386 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
387 [ JS.String (N.toBuilder name)
388 , Expr.codeToExpr (Expr.generate mode converter)
389 ]
390 in
391 JS.Var [ (Name.fromGlobal home name, Just definition) ]
395-- GENERATE MANAGER
398generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
399generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
400 let
401 managerLVar =
402 JS.LBracket
403 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
404 (JS.String (N.toBuilder moduleName))
406 (deps, args, stmts) =
407 generateManagerHelp home effectsType
409 createManager =
410 JS.ExprStmt $ JS.Assign managerLVar $
411 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
412 in
413 addStmt (List.foldl' (addGlobal mode graph) state deps) $
414 JS.Block (createManager : stmts)
417generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
418generateLeaf home@(ModuleName.Canonical _ moduleName) name =
419 let
420 definition =
421 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
422 in
423 JS.Var [ (Name.fromGlobal home name, Just definition) ]
426{-# NOINLINE leaf #-}
427leaf :: JS.Expr
428leaf =
429 JS.Ref (Name.fromKernel N.platform "leaf")
432generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
433generateManagerHelp home effectsType =
434 let
435 dep name = Opt.Global home name
436 ref name = JS.Ref (Name.fromGlobal home name)
437 in
438 case effectsType of
439 Opt.Cmd ->
440 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
441 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
442 , [ generateLeaf home "command" ]
443 )
445 Opt.Sub ->
446 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
447 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
448 , [ generateLeaf home "subscription" ]
449 )
451 Opt.Fx ->
452 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
453 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
454 , [ generateLeaf home "command"
455 , generateLeaf home "subscription"
456 ]
457 )
461-- MAIN EXPORTS
464toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
465toMainExports mode mains =
466 let
467 export = Name.fromKernel N.platform "export"
468 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
469 in
470 Name.toBuilder export <> "(" <> exports <> ");"
473generateExports :: Mode.Mode -> Trie -> B.Builder
474generateExports mode (Trie maybeMain subs) =
475 let
476 object =
477 case Map.toList subs of
478 [] ->
479 "{}"
481 (name, subTrie) : otherSubTries ->
482 "{'" <> Text.encodeUtf8Builder name <> "':"
483 <> generateExports mode subTrie
484 <> List.foldl' (addSubTrie mode) "}" otherSubTries
485 in
486 case maybeMain of
487 Nothing ->
488 object
490 Just (home, main) ->
491 let initialize = Expr.generateMain mode home main in
492 JS.exprToBuilder initialize <> "(" <> object <> ")"
495addSubTrie :: Mode.Mode -> B.Builder -> (Text.Text, Trie) -> B.Builder
496addSubTrie mode end (name, trie) =
497 ",'" <> Text.encodeUtf8Builder name <> "':" <> generateExports mode trie <> end
501-- BUILD TRIES
504data Trie =
505 Trie
506 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
507 , _subs :: Map.Map Text.Text Trie
508 }
511emptyTrie :: Trie
512emptyTrie =
513 Trie Nothing Map.empty
516addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
517addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
518 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
521segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
522segmentsToTrie home segments main =
523 case segments of
524 [] ->
525 Trie (Just (home, main)) Map.empty
527 segment : otherSegments ->
528 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
531merge :: Trie -> Trie -> Trie
532merge (Trie main1 subs1) (Trie main2 subs2) =
533 Trie
534 (checkedMerge main1 main2)
535 (Map.unionWith merge subs1 subs2)
538checkedMerge :: Maybe a -> Maybe a -> Maybe a
539checkedMerge a b =
540 case (a, b) of
541 (Nothing, main) ->
542 main
544 (main, Nothing) ->
545 main
547 (Just _, Just _) ->
548 error "cannot have two modules with the same name"