git.iko.soy/elk
on ca94170 help sign in
elk/compiler/src/Generate/JavaScript.hs
528 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 :: Opt.Graph -> I.Interface -> ModuleName.Canonical -> N.Name -> B.Builder
72generateForRepl (Opt.Graph _ graph _) iface home name =
73 let
74 mode = Mode.dev Mode.Server
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 home name (I._types iface ! name)
81print :: ModuleName.Canonical -> N.Name -> Can.Annotation -> B.Builder
82print home name annotation =
83 let
84 value = Name.toBuilder (Name.fromGlobal home name)
85 toString = Name.toBuilder (Name.fromKernel N.debug "toString")
86 tipe = Type.toDoc Type.None (Extract.fromAnnotation annotation)
87 in
88 "var _value = " <> toString <> "(" <> value <> ");\n" <>
89 "var _type = " <> B.stringUtf8 (show (D.toString tipe)) <> ";\n\
90 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
91 \ console.log(_value + '\\n : ' + _type.split('\\n').join('\\n '));\n\
92 \} else {\n\
93 \ console.log(_value + ' : ' + _type);\n\
94 \}\n"
98-- GRAPH TRAVERSAL STATE
101data State =
102 State
103 { _revBuilders :: [B.Builder]
104 , _seenGlobals :: Set.Set Opt.Global
105 }
108emptyState :: State
109emptyState =
110 State [] Set.empty
113stateToBuilder :: State -> B.Builder
114stateToBuilder (State revBuilders _) =
115 List.foldl1' (\builder b -> b <> builder) revBuilders
119-- ADD DEPENDENCIES
122type Graph = Map.Map Opt.Global Opt.Node
125addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
126addGlobal mode graph state@(State builders seen) global =
127 if Set.member global seen then
128 state
129 else
130 addGlobalHelp mode graph global $
131 State builders (Set.insert global seen)
134addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
135addGlobalHelp mode graph global state =
136 let
137 addDeps deps someState =
138 Set.foldl' (addGlobal mode graph) someState deps
139 in
140 case graph ! global of
141 Opt.Define expr deps ->
142 addStmt (addDeps deps state) (
143 var global (Expr.generate mode expr)
144 )
146 Opt.DefineTailFunc argNames body deps ->
147 addStmt (addDeps deps state) (
148 let (Opt.Global _ name) = global in
149 var global (Expr.generateTailDef mode name argNames body)
150 )
152 Opt.Ctor name index arity ->
153 addStmt state (
154 var global (Expr.generateCtor mode name index arity)
155 )
157 Opt.Link linkedGlobal ->
158 addGlobal mode graph state linkedGlobal
160 Opt.Cycle cycle deps ->
161 addStmt (addDeps deps state) (
162 generateCycle mode global cycle
163 )
165 Opt.Manager effectsType ->
166 generateManager mode graph global effectsType state
168 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
169 if isDebugger global && not (Mode.isDebug mode) then
170 state
171 else
172 case maybeServer of
173 Just (Opt.KContent serverChunks serverDeps) | Mode.isServer mode ->
174 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
176 _ ->
177 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
179 Opt.Enum name index ->
180 addStmt state (
181 generateEnum mode global name index
182 )
184 Opt.Box name ->
185 addStmt state (
186 generateBox mode global name
187 )
189 Opt.PortIncoming decoder deps ->
190 addStmt (addDeps deps state) (
191 generatePort mode global "incomingPort" decoder
192 )
194 Opt.PortOutgoing encoder deps ->
195 addStmt (addDeps deps state) (
196 generatePort mode global "outgoingPort" encoder
197 )
200addStmt :: State -> JS.Stmt -> State
201addStmt state stmt =
202 addBuilder state (JS.stmtToBuilder stmt)
205addBuilder :: State -> B.Builder -> State
206addBuilder (State revBuilders seen) builder =
207 State (builder:revBuilders) seen
210var :: Opt.Global -> Expr.Code -> JS.Stmt
211var (Opt.Global home name) code =
212 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
215isDebugger :: Opt.Global -> Bool
216isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
217 home == N.debugger
221-- GENERATE CYCLES
224generateCycle :: Mode.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
225generateCycle mode (Opt.Global home _) cycle =
226 let
227 safeDefs = map (generateSafeCycle mode home) cycle
228 realDefs = map (generateRealCycle home) cycle
229 block = JS.Block (safeDefs ++ realDefs)
230 in
231 case mode of
232 Mode.Prod _ _ ->
233 block
235 Mode.Dev _ _ ->
236 JS.Try block Name.dollar $ JS.Throw $ JS.String $
237 "The following top-level definitions are causing infinite recursion:\\n"
238 <> drawCycle (map fst cycle)
239 <> "\\n\\nThese errors are very tricky, so read "
240 <> B.stringUtf8 (D.makeLink "halting-problem")
241 <> " to learn how to fix it!"
244generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
245generateSafeCycle mode home (name, expr) =
246 JS.FunctionStmt (Name.fromCycle home name) [] $
247 Expr.codeToStmtList (Expr.generate mode expr)
250generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
251generateRealCycle home (name, _) =
252 let
253 safeName = Name.fromCycle home name
254 realName = Name.fromGlobal home name
255 in
256 JS.Block
257 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
258 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
259 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
260 ]
263drawCycle :: [N.Name] -> B.Builder
264drawCycle names =
265 let
266 topLine = "\\n ┌─────┐"
267 nameLine name = "\\n │ " <> N.toBuilder name
268 midLine = "\\n │ ↓"
269 bottomLine = "\\n └─────┘"
270 in
271 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
276-- GENERATE KERNEL
279generateKernel :: Mode.Mode -> [Opt.KChunk] -> B.Builder
280generateKernel mode chunks =
281 List.foldl' (addChunk mode) mempty chunks
284addChunk :: Mode.Mode -> B.Builder -> Opt.KChunk -> B.Builder
285addChunk mode builder chunk =
286 case chunk of
287 Opt.JS javascript ->
288 B.byteString javascript <> builder
290 Opt.ElmVar home name ->
291 Name.toBuilder (Name.fromGlobal home name) <> builder
293 Opt.JsVar home name ->
294 Name.toBuilder (Name.fromKernel home name) <> builder
296 Opt.ElmField name ->
297 Name.toBuilder (Expr.generateField mode name) <> builder
299 Opt.JsField int ->
300 Name.toBuilder (Name.fromInt int) <> builder
302 Opt.JsEnum int ->
303 B.intDec int <> builder
305 Opt.Debug ->
306 case mode of
307 Mode.Dev _ _ ->
308 builder
310 Mode.Prod _ _ ->
311 "_UNUSED" <> builder
313 Opt.Prod ->
314 case mode of
315 Mode.Dev _ _ ->
316 "_UNUSED" <> builder
318 Mode.Prod _ _ ->
319 builder
323-- GENERATE ENUM
326generateEnum :: Mode.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
327generateEnum mode (Opt.Global home name) ctorName index =
328 let
329 definition =
330 case mode of
331 Mode.Dev _ _ ->
332 Expr.codeToExpr (Expr.generateCtor mode ctorName index 0)
334 Mode.Prod _ _ ->
335 JS.Int (Index.toMachine index)
336 in
337 JS.Var [ (Name.fromGlobal home name, Just definition) ]
341-- GENERATE BOX
344generateBox :: Mode.Mode -> Opt.Global -> N.Name -> JS.Stmt
345generateBox mode (Opt.Global home name) ctorName =
346 let
347 definition =
348 case mode of
349 Mode.Dev _ _ ->
350 Expr.codeToExpr (Expr.generateCtor mode ctorName Index.first 1)
352 Mode.Prod _ _ ->
353 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
354 in
355 JS.Var [ (Name.fromGlobal home name, Just definition) ]
359-- GENERATE PORTS
362generatePort :: Mode.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
363generatePort mode (Opt.Global home name) makePort converter =
364 let
365 definition =
366 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
367 [ JS.String (N.toBuilder name)
368 , Expr.codeToExpr (Expr.generate mode converter)
369 ]
370 in
371 JS.Var [ (Name.fromGlobal home name, Just definition) ]
375-- GENERATE MANAGER
378generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
379generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
380 let
381 managerLVar =
382 JS.LBracket
383 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
384 (JS.String (N.toBuilder moduleName))
386 (deps, args, stmts) =
387 generateManagerHelp home effectsType
389 createManager =
390 JS.ExprStmt $ JS.Assign managerLVar $
391 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
392 in
393 addStmt (List.foldl' (addGlobal mode graph) state deps) $
394 JS.Block (createManager : stmts)
397generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
398generateLeaf home@(ModuleName.Canonical _ moduleName) name =
399 let
400 definition =
401 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
402 in
403 JS.Var [ (Name.fromGlobal home name, Just definition) ]
406{-# NOINLINE leaf #-}
407leaf :: JS.Expr
408leaf =
409 JS.Ref (Name.fromKernel N.platform "leaf")
412generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
413generateManagerHelp home effectsType =
414 let
415 dep name = Opt.Global home name
416 ref name = JS.Ref (Name.fromGlobal home name)
417 in
418 case effectsType of
419 Opt.Cmd ->
420 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
421 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
422 , [ generateLeaf home "command" ]
423 )
425 Opt.Sub ->
426 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
427 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
428 , [ generateLeaf home "subscription" ]
429 )
431 Opt.Fx ->
432 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
433 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
434 , [ generateLeaf home "command"
435 , generateLeaf home "subscription"
436 ]
437 )
441-- MAIN EXPORTS
444toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
445toMainExports mode mains =
446 let
447 export = Name.fromKernel N.platform "export"
448 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
449 in
450 Name.toBuilder export <> "(" <> exports <> ");"
453generateExports :: Mode.Mode -> Trie -> B.Builder
454generateExports mode (Trie maybeMain subs) =
455 let
456 object =
457 case Map.toList subs of
458 [] ->
459 "{}"
461 (name, subTrie) : otherSubTries ->
462 "{'" <> Text.encodeUtf8Builder name <> "':"
463 <> generateExports mode subTrie
464 <> List.foldl' (addSubTrie mode) "}" otherSubTries
465 in
466 case maybeMain of
467 Nothing ->
468 object
470 Just (home, main) ->
471 let initialize = Expr.generateMain mode home main in
472 JS.exprToBuilder initialize <> "(" <> object <> ")"
475addSubTrie :: Mode.Mode -> B.Builder -> (Text.Text, Trie) -> B.Builder
476addSubTrie mode end (name, trie) =
477 ",'" <> Text.encodeUtf8Builder name <> "':" <> generateExports mode trie <> end
481-- BUILD TRIES
484data Trie =
485 Trie
486 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
487 , _subs :: Map.Map Text.Text Trie
488 }
491emptyTrie :: Trie
492emptyTrie =
493 Trie Nothing Map.empty
496addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
497addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
498 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
501segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
502segmentsToTrie home segments main =
503 case segments of
504 [] ->
505 Trie (Just (home, main)) Map.empty
507 segment : otherSegments ->
508 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
511merge :: Trie -> Trie -> Trie
512merge (Trie main1 subs1) (Trie main2 subs2) =
513 Trie
514 (checkedMerge main1 main2)
515 (Map.unionWith merge subs1 subs2)
518checkedMerge :: Maybe a -> Maybe a -> Maybe a
519checkedMerge a b =
520 case (a, b) of
521 (Nothing, main) ->
522 main
524 (main, Nothing) ->
525 main
527 (Just _, Just _) ->
528 error "cannot have two modules with the same name"