git.iko.soy/elk
on 49f58cf help sign in
elk/compiler/src/Generate/JavaScript.hs
530 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.Compiler.Type as Type
25import qualified Elm.Compiler.Type.Extract as Extract
26import qualified Elm.Interface as I
27import qualified Elm.Name as N
28import qualified Generate.JavaScript.Builder as JS
29import qualified Generate.JavaScript.Expression as Expr
30import qualified Generate.JavaScript.Name as Name
31import qualified Generate.JavaScript.Mode as Mode
32import qualified Reporting.Doc as D
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 = 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")
68-- GENERATE FOR REPL
71generateForRepl :: Bool -> Opt.Graph -> I.Interface -> ModuleName.Canonical -> N.Name -> B.Builder
72generateForRepl ansi (Opt.Graph _ graph _) iface home name =
73 let
74 mode = Mode.dev Mode.Client
75 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
76 evalState = addGlobal mode graph debugState (Opt.Global home name)
77 in
78 stateToBuilder evalState <> print ansi home name (I._types iface ! name)
81print :: Bool -> ModuleName.Canonical -> N.Name -> Can.Annotation -> B.Builder
82print ansi home name annotation =
83 let
84 value = Name.toBuilder (Name.fromGlobal home name)
85 toString = Name.toBuilder (Name.fromKernel N.debug "toAnsiString")
86 tipe = Type.toDoc Type.None (Extract.fromAnnotation annotation)
87 bool = if ansi then "true" else "false"
88 in
89 "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
90 \var _type = " <> B.stringUtf8 (show (D.toString tipe)) <> ";\n\
91 \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
92 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
93 \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
94 \} else {\n\
95 \ _print(' : ' + _type);\n\
96 \}\n"
100-- GRAPH TRAVERSAL STATE
103data State =
104 State
105 { _revBuilders :: [B.Builder]
106 , _seenGlobals :: Set.Set Opt.Global
107 }
110emptyState :: State
111emptyState =
112 State [] Set.empty
115stateToBuilder :: State -> B.Builder
116stateToBuilder (State revBuilders _) =
117 List.foldl1' (\builder b -> b <> builder) revBuilders
121-- ADD DEPENDENCIES
124type Graph = Map.Map Opt.Global Opt.Node
127addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
128addGlobal mode graph state@(State builders seen) global =
129 if Set.member global seen then
130 state
131 else
132 addGlobalHelp mode graph global $
133 State builders (Set.insert global seen)
136addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
137addGlobalHelp mode graph global state =
138 let
139 addDeps deps someState =
140 Set.foldl' (addGlobal mode graph) someState deps
141 in
142 case graph ! global of
143 Opt.Define expr deps ->
144 addStmt (addDeps deps state) (
145 var global (Expr.generate mode expr)
146 )
148 Opt.DefineTailFunc argNames body deps ->
149 addStmt (addDeps deps state) (
150 let (Opt.Global _ name) = global in
151 var global (Expr.generateTailDef mode name argNames body)
152 )
154 Opt.Ctor index arity ->
155 addStmt state (
156 var global (Expr.generateCtor mode global index arity)
157 )
159 Opt.Link linkedGlobal ->
160 addGlobal mode graph state linkedGlobal
162 Opt.Cycle cycle deps ->
163 addStmt (addDeps deps state) (
164 generateCycle mode global cycle
165 )
167 Opt.Manager effectsType ->
168 generateManager mode graph global effectsType state
170 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
171 if isDebugger global && not (Mode.isDebug mode) then
172 state
173 else
174 case maybeServer of
175 Just (Opt.KContent serverChunks serverDeps) | Mode.isServer mode ->
176 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
178 _ ->
179 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
181 Opt.Enum index ->
182 addStmt state (
183 generateEnum mode global index
184 )
186 Opt.Box ->
187 addStmt state (
188 generateBox mode global
189 )
191 Opt.PortIncoming decoder deps ->
192 addStmt (addDeps deps state) (
193 generatePort mode global "incomingPort" decoder
194 )
196 Opt.PortOutgoing encoder deps ->
197 addStmt (addDeps deps state) (
198 generatePort mode global "outgoingPort" encoder
199 )
202addStmt :: State -> JS.Stmt -> State
203addStmt state stmt =
204 addBuilder state (JS.stmtToBuilder stmt)
207addBuilder :: State -> B.Builder -> State
208addBuilder (State revBuilders seen) builder =
209 State (builder:revBuilders) seen
212var :: Opt.Global -> Expr.Code -> JS.Stmt
213var (Opt.Global home name) code =
214 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
217isDebugger :: Opt.Global -> Bool
218isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
219 home == N.debugger
223-- GENERATE CYCLES
226generateCycle :: Mode.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
227generateCycle mode (Opt.Global home _) cycle =
228 let
229 safeDefs = map (generateSafeCycle mode home) cycle
230 realDefs = map (generateRealCycle home) cycle
231 block = JS.Block (safeDefs ++ realDefs)
232 in
233 case mode of
234 Mode.Prod _ _ ->
235 block
237 Mode.Dev _ _ ->
238 JS.Try block Name.dollar $ JS.Throw $ JS.String $
239 "The following top-level definitions are causing infinite recursion:\\n"
240 <> drawCycle (map fst cycle)
241 <> "\\n\\nThese errors are very tricky, so read "
242 <> B.stringUtf8 (D.makeLink "halting-problem")
243 <> " to learn how to fix it!"
246generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
247generateSafeCycle mode home (name, expr) =
248 JS.FunctionStmt (Name.fromCycle home name) [] $
249 Expr.codeToStmtList (Expr.generate mode expr)
252generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
253generateRealCycle home (name, _) =
254 let
255 safeName = Name.fromCycle home name
256 realName = Name.fromGlobal home name
257 in
258 JS.Block
259 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
260 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
261 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
262 ]
265drawCycle :: [N.Name] -> B.Builder
266drawCycle names =
267 let
268 topLine = "\\n ┌─────┐"
269 nameLine name = "\\n │ " <> N.toBuilder name
270 midLine = "\\n │ ↓"
271 bottomLine = "\\n └─────┘"
272 in
273 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
278-- GENERATE KERNEL
281generateKernel :: Mode.Mode -> [Opt.KChunk] -> B.Builder
282generateKernel mode chunks =
283 List.foldl' (addChunk mode) mempty chunks
286addChunk :: Mode.Mode -> B.Builder -> Opt.KChunk -> B.Builder
287addChunk mode builder chunk =
288 case chunk of
289 Opt.JS javascript ->
290 B.byteString javascript <> builder
292 Opt.ElmVar home name ->
293 Name.toBuilder (Name.fromGlobal home name) <> builder
295 Opt.JsVar home name ->
296 Name.toBuilder (Name.fromKernel home name) <> builder
298 Opt.ElmField name ->
299 Name.toBuilder (Expr.generateField mode name) <> builder
301 Opt.JsField int ->
302 Name.toBuilder (Name.fromInt int) <> builder
304 Opt.JsEnum int ->
305 B.intDec int <> builder
307 Opt.Debug ->
308 case mode of
309 Mode.Dev _ _ ->
310 builder
312 Mode.Prod _ _ ->
313 "_UNUSED" <> builder
315 Opt.Prod ->
316 case mode of
317 Mode.Dev _ _ ->
318 "_UNUSED" <> builder
320 Mode.Prod _ _ ->
321 builder
325-- GENERATE ENUM
328generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
329generateEnum mode global@(Opt.Global home name) index =
330 let
331 definition =
332 case mode of
333 Mode.Dev _ _ ->
334 Expr.codeToExpr (Expr.generateCtor mode global index 0)
336 Mode.Prod _ _ ->
337 JS.Int (Index.toMachine index)
338 in
339 JS.Var [ (Name.fromGlobal home name, Just definition) ]
343-- GENERATE BOX
346generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
347generateBox mode global@(Opt.Global home name) =
348 let
349 definition =
350 case mode of
351 Mode.Dev _ _ ->
352 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
354 Mode.Prod _ _ ->
355 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
356 in
357 JS.Var [ (Name.fromGlobal home name, Just definition) ]
361-- GENERATE PORTS
364generatePort :: Mode.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
365generatePort mode (Opt.Global home name) makePort converter =
366 let
367 definition =
368 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
369 [ JS.String (N.toBuilder name)
370 , Expr.codeToExpr (Expr.generate mode converter)
371 ]
372 in
373 JS.Var [ (Name.fromGlobal home name, Just definition) ]
377-- GENERATE MANAGER
380generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
381generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
382 let
383 managerLVar =
384 JS.LBracket
385 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
386 (JS.String (N.toBuilder moduleName))
388 (deps, args, stmts) =
389 generateManagerHelp home effectsType
391 createManager =
392 JS.ExprStmt $ JS.Assign managerLVar $
393 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
394 in
395 addStmt (List.foldl' (addGlobal mode graph) state deps) $
396 JS.Block (createManager : stmts)
399generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
400generateLeaf home@(ModuleName.Canonical _ moduleName) name =
401 let
402 definition =
403 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
404 in
405 JS.Var [ (Name.fromGlobal home name, Just definition) ]
408{-# NOINLINE leaf #-}
409leaf :: JS.Expr
410leaf =
411 JS.Ref (Name.fromKernel N.platform "leaf")
414generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
415generateManagerHelp home effectsType =
416 let
417 dep name = Opt.Global home name
418 ref name = JS.Ref (Name.fromGlobal home name)
419 in
420 case effectsType of
421 Opt.Cmd ->
422 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
423 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
424 , [ generateLeaf home "command" ]
425 )
427 Opt.Sub ->
428 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
429 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
430 , [ generateLeaf home "subscription" ]
431 )
433 Opt.Fx ->
434 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
435 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
436 , [ generateLeaf home "command"
437 , generateLeaf home "subscription"
438 ]
439 )
443-- MAIN EXPORTS
446toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
447toMainExports mode mains =
448 let
449 export = Name.fromKernel N.platform "export"
450 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
451 in
452 Name.toBuilder export <> "(" <> exports <> ");"
455generateExports :: Mode.Mode -> Trie -> B.Builder
456generateExports mode (Trie maybeMain subs) =
457 let
458 object =
459 case Map.toList subs of
460 [] ->
461 "{}"
463 (name, subTrie) : otherSubTries ->
464 "{'" <> Text.encodeUtf8Builder name <> "':"
465 <> generateExports mode subTrie
466 <> List.foldl' (addSubTrie mode) "}" otherSubTries
467 in
468 case maybeMain of
469 Nothing ->
470 object
472 Just (home, main) ->
473 let initialize = Expr.generateMain mode home main in
474 JS.exprToBuilder initialize <> "(" <> object <> ")"
477addSubTrie :: Mode.Mode -> B.Builder -> (Text.Text, Trie) -> B.Builder
478addSubTrie mode end (name, trie) =
479 ",'" <> Text.encodeUtf8Builder name <> "':" <> generateExports mode trie <> end
483-- BUILD TRIES
486data Trie =
487 Trie
488 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
489 , _subs :: Map.Map Text.Text Trie
490 }
493emptyTrie :: Trie
494emptyTrie =
495 Trie Nothing Map.empty
498addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
499addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
500 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
503segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
504segmentsToTrie home segments main =
505 case segments of
506 [] ->
507 Trie (Just (home, main)) Map.empty
509 segment : otherSegments ->
510 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
513merge :: Trie -> Trie -> Trie
514merge (Trie main1 subs1) (Trie main2 subs2) =
515 Trie
516 (checkedMerge main1 main2)
517 (Map.unionWith merge subs1 subs2)
520checkedMerge :: Maybe a -> Maybe a -> Maybe a
521checkedMerge a b =
522 case (a, b) of
523 (Nothing, main) ->
524 main
526 (main, Nothing) ->
527 main
529 (Just _, Just _) ->
530 error "cannot have two modules with the same name"