git.iko.soy/elk
on a36152c help sign in
elk/compiler/src/Generate/JavaScript.hs
540 lines 14 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript
3 ( Mode(..)
4 , Output(..)
5 , generate
6 , generateForRepl
7 )
8 where
11import Prelude hiding (cycle, print)
12import qualified Data.ByteString.Builder as B
13import Data.Monoid ((<>))
14import qualified Data.List as List
15import Data.Map ((!))
16import qualified Data.Map as Map
17import qualified Data.Set as Set
18import qualified Data.Text as Text
19import qualified Data.Text.Encoding as Text
21import qualified AST.Canonical as Can
22import qualified AST.Optimized as Opt
23import qualified AST.Module.Name as ModuleName
24import qualified Data.Index as Index
25import qualified Elm.Compiler.Type as Type
26import qualified Elm.Compiler.Type.Extract as Extract
27import qualified Elm.Interface as I
28import qualified Elm.Name as N
29import qualified Generate.JavaScript.Builder as JS
30import qualified Generate.JavaScript.Expression as Expr
31import qualified Generate.JavaScript.Name as Name
32import qualified Reporting.Doc as D
36-- GENERATE MAINS
39data Mode = Dev | Prod
42data Output
43 = None
44 | Some N.Name [N.Name] B.Builder
47generate :: Mode -> Name.Target -> I.Interfaces -> Opt.Graph -> [ModuleName.Canonical] -> Output
48generate mode target interfaces (Opt.Graph mains graph fields) roots =
49 let
50 rootSet = Set.fromList roots
51 rootMap = Map.restrictKeys mains rootSet
52 in
53 case map ModuleName._module (Map.keys rootMap) of
54 [] ->
55 None
57 name:names ->
58 let
59 realMode = toRealMode mode target fields
60 state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap
61 builder = stateToBuilder state <> toMainExports realMode interfaces rootMap
62 in
63 Some name names builder
66addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
67addMain mode graph home _ state =
68 addGlobal mode graph state (Opt.Global home "main")
71toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
72toRealMode mode target fields =
73 case mode of
74 Dev ->
75 Name.Dev target
77 Prod ->
78 Name.Prod target (Name.shortenFieldNames fields)
82-- GENERATE FOR REPL
85generateForRepl :: Opt.Graph -> I.Interface -> ModuleName.Canonical -> N.Name -> B.Builder
86generateForRepl (Opt.Graph _ graph _) iface home name =
87 let
88 mode = Name.Dev Name.Server
89 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
90 evalState = addGlobal mode graph debugState (Opt.Global home name)
91 in
92 stateToBuilder evalState <> print home name (I._types iface ! name)
95print :: ModuleName.Canonical -> N.Name -> Can.Annotation -> B.Builder
96print home name annotation =
97 let
98 value = Name.toBuilder (Name.fromGlobal home name)
99 toString = Name.toBuilder (Name.fromKernel N.debug "toString")
100 tipe = Type.toDoc Type.None (Extract.fromAnnotation annotation)
101 in
102 "var _value = " <> toString <> "(" <> value <> ");\n" <>
103 "var _type = " <> B.stringUtf8 (show (D.toString tipe)) <> ";\n\
104 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
105 \ console.log(_value + '\\n : ' + _type.split('\\n').join('\\n '));\n\
106 \} else {\n\
107 \ console.log(_value + ' : ' + _type);\n\
108 \}\n"
112-- GRAPH TRAVERSAL STATE
115data State =
116 State
117 { _revBuilders :: [B.Builder]
118 , _seenGlobals :: Set.Set Opt.Global
119 }
122emptyState :: State
123emptyState =
124 State [] Set.empty
127stateToBuilder :: State -> B.Builder
128stateToBuilder (State revBuilders _) =
129 List.foldl1' (\builder b -> b <> builder) revBuilders
133-- ADD DEPENDENCIES
136type Graph = Map.Map Opt.Global Opt.Node
139addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
140addGlobal mode graph state@(State builders seen) global =
141 if Set.member global seen then
142 state
143 else
144 addGlobalHelp mode graph global $
145 State builders (Set.insert global seen)
148addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
149addGlobalHelp mode graph global state =
150 let
151 addDeps deps someState =
152 Set.foldl' (addGlobal mode graph) someState deps
153 in
154 case graph ! global of
155 Opt.Define expr deps ->
156 addStmt (addDeps deps state) (
157 var global (Expr.generate mode expr)
158 )
160 Opt.DefineTailFunc argNames body deps ->
161 addStmt (addDeps deps state) (
162 let (Opt.Global _ name) = global in
163 var global (Expr.generateTailDef mode name argNames body)
164 )
166 Opt.Ctor name index arity ->
167 addStmt state (
168 var global (Expr.generateCtor mode name index arity)
169 )
171 Opt.Link linkedGlobal ->
172 addGlobal mode graph state linkedGlobal
174 Opt.Cycle cycle deps ->
175 addStmt (addDeps deps state) (
176 generateCycle mode global cycle
177 )
179 Opt.Manager effectsType ->
180 generateManager mode graph global effectsType state
182 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
183 case maybeServer of
184 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
185 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
187 _ ->
188 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
190 Opt.Enum name index ->
191 addStmt state (
192 generateEnum mode global name index
193 )
195 Opt.Box name ->
196 addStmt state (
197 generateBox mode global name
198 )
200 Opt.PortIncoming decoder deps ->
201 addStmt (addDeps deps state) (
202 generatePort mode global "incomingPort" decoder
203 )
205 Opt.PortOutgoing encoder deps ->
206 addStmt (addDeps deps state) (
207 generatePort mode global "outgoingPort" encoder
208 )
211addStmt :: State -> JS.Stmt -> State
212addStmt state stmt =
213 addBuilder state (JS.stmtToBuilder stmt)
216addBuilder :: State -> B.Builder -> State
217addBuilder (State revBuilders seen) builder =
218 State (builder:revBuilders) seen
221var :: Opt.Global -> Expr.Code -> JS.Stmt
222var (Opt.Global home name) code =
223 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
227-- GENERATE CYCLES
230generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
231generateCycle mode (Opt.Global home _) cycle =
232 let
233 safeDefs = map (generateSafeCycle mode home) cycle
234 realDefs = map (generateRealCycle home) cycle
235 block = JS.Block (safeDefs ++ realDefs)
236 in
237 case mode of
238 Name.Prod _ _ ->
239 block
241 Name.Dev _ ->
242 JS.Try block Name.dollar $ JS.Throw $ JS.String $
243 "The following top-level definitions are causing infinite recursion:\\n"
244 <> drawCycle (map fst cycle)
245 <> "\\n\\nThese errors are very tricky, so read "
246 <> B.stringUtf8 (D.makeLink "halting-problem")
247 <> " to learn how to fix it!"
250generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
251generateSafeCycle mode home (name, expr) =
252 JS.FunctionStmt (Name.fromCycle home name) [] $
253 Expr.codeToStmtList (Expr.generate mode expr)
256generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
257generateRealCycle home (name, _) =
258 let
259 safeName = Name.fromCycle home name
260 realName = Name.fromGlobal home name
261 in
262 JS.Block
263 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
264 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
265 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
266 ]
269drawCycle :: [N.Name] -> B.Builder
270drawCycle names =
271 let
272 topLine = "\\n ┌─────┐"
273 nameLine name = "\\n │ " <> N.toBuilder name
274 midLine = "\\n │ ↓"
275 bottomLine = "\\n └─────┘"
276 in
277 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
282-- GENERATE KERNEL
285generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
286generateKernel mode chunks =
287 List.foldl' (addChunk mode) mempty chunks
290addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
291addChunk mode builder chunk =
292 case chunk of
293 Opt.JS javascript ->
294 B.byteString javascript <> builder
296 Opt.ElmVar home name ->
297 Name.toBuilder (Name.fromGlobal home name) <> builder
299 Opt.JsVar home name ->
300 Name.toBuilder (Name.fromKernel home name) <> builder
302 Opt.ElmField name ->
303 Name.toBuilder (Name.fromField mode name) <> builder
305 Opt.JsField int ->
306 Name.toBuilder (Name.fromInt int) <> builder
308 Opt.JsEnum int ->
309 B.intDec int <> builder
311 Opt.Debug ->
312 case mode of
313 Name.Dev _ ->
314 builder
316 Name.Prod _ _ ->
317 "_UNUSED" <> builder
319 Opt.Prod ->
320 case mode of
321 Name.Dev _ ->
322 "_UNUSED" <> builder
324 Name.Prod _ _ ->
325 builder
329-- GENERATE ENUM
332generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
333generateEnum mode (Opt.Global home name) ctorName index =
334 let
335 definition =
336 case mode of
337 Name.Dev _ ->
338 Expr.codeToExpr (Expr.generateCtor mode ctorName index 0)
340 Name.Prod _ _ ->
341 JS.Int (Index.toMachine index)
342 in
343 JS.Var [ (Name.fromGlobal home name, Just definition) ]
347-- GENERATE BOX
350generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
351generateBox mode (Opt.Global home name) ctorName =
352 let
353 definition =
354 case mode of
355 Name.Dev _ ->
356 Expr.codeToExpr (Expr.generateCtor mode ctorName Index.first 1)
358 Name.Prod _ _ ->
359 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
360 in
361 JS.Var [ (Name.fromGlobal home name, Just definition) ]
365-- GENERATE PORTS
368generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
369generatePort mode (Opt.Global home name) makePort converter =
370 let
371 definition =
372 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
373 [ JS.String (N.toBuilder name)
374 , Expr.codeToExpr (Expr.generate mode converter)
375 ]
376 in
377 JS.Var [ (Name.fromGlobal home name, Just definition) ]
381-- GENERATE MANAGER
384generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
385generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
386 let
387 managerLVar =
388 JS.LBracket
389 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
390 (JS.String (N.toBuilder moduleName))
392 (deps, args, stmts) =
393 generateManagerHelp home effectsType
395 createManager =
396 JS.ExprStmt $ JS.Assign managerLVar $
397 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
398 in
399 addStmt (List.foldl' (addGlobal mode graph) state deps) $
400 JS.Block (createManager : stmts)
403generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
404generateLeaf home@(ModuleName.Canonical _ moduleName) name =
405 let
406 definition =
407 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
408 in
409 JS.Var [ (Name.fromGlobal home name, Just definition) ]
412{-# NOINLINE leaf #-}
413leaf :: JS.Expr
414leaf =
415 JS.Ref (Name.fromKernel N.platform "leaf")
418generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
419generateManagerHelp home effectsType =
420 let
421 dep name = Opt.Global home name
422 ref name = JS.Ref (Name.fromGlobal home name)
423 in
424 case effectsType of
425 Opt.Cmd ->
426 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
427 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
428 , [ generateLeaf home "command" ]
429 )
431 Opt.Sub ->
432 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
433 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
434 , [ generateLeaf home "subscription" ]
435 )
437 Opt.Fx ->
438 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
439 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
440 , [ generateLeaf home "command"
441 , generateLeaf home "subscription"
442 ]
443 )
447-- MAIN EXPORTS
450toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
451toMainExports mode interfaces mains =
452 let
453 export =
454 Name.fromKernel N.platform "export"
456 exports =
457 generateExports mode interfaces $
458 Map.foldrWithKey addToTrie emptyTrie mains
459 in
460 Name.toBuilder export <> "(" <> exports <> ");"
463generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
464generateExports mode interfaces (Trie maybeMain subs) =
465 let
466 object =
467 case Map.toList subs of
468 [] ->
469 "{}"
471 (name, subTrie) : otherSubTries ->
472 "{'" <> Text.encodeUtf8Builder name <> "':"
473 <> generateExports mode interfaces subTrie
474 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
475 in
476 case maybeMain of
477 Nothing ->
478 object
480 Just (home, main) ->
481 let initialize = Expr.generateMain mode interfaces home main in
482 JS.exprToBuilder initialize <> "(" <> object <> ")"
485addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (Text.Text, Trie) -> B.Builder
486addSubTrie mode interfaces end (name, trie) =
487 ",'" <> Text.encodeUtf8Builder name <> "':"
488 <> generateExports mode interfaces trie
489 <> end
493-- BUILD TRIES
496data Trie =
497 Trie
498 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
499 , _subs :: Map.Map Text.Text Trie
500 }
503emptyTrie :: Trie
504emptyTrie =
505 Trie Nothing Map.empty
508addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
509addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
510 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
513segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
514segmentsToTrie home segments main =
515 case segments of
516 [] ->
517 Trie (Just (home, main)) Map.empty
519 segment : otherSegments ->
520 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
523merge :: Trie -> Trie -> Trie
524merge (Trie main1 subs1) (Trie main2 subs2) =
525 Trie
526 (checkedMerge main1 main2)
527 (Map.unionWith merge subs1 subs2)
530checkedMerge :: Maybe a -> Maybe a -> Maybe a
531checkedMerge a b =
532 case (a, b) of
533 (Nothing, main) ->
534 main
536 (main, Nothing) ->
537 main
539 (Just _, Just _) ->
540 error "cannot have two modules with the same name"