git.iko.soy/elk
on d4e9599 help sign in
elk/compiler/src/Generate/JavaScript.hs
534 lines 14 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript
4 ( Mode(..)
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
20import qualified Text.PrettyPrint.ANSI.Leijen as P
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.Helpers as H
36-- GENERATE MAINS
39data Mode = Debug | Prod
42generate :: Mode -> Name.Target -> I.Interfaces -> Opt.Graph -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] B.Builder
43generate mode target interfaces (Opt.Graph mains graph fields) roots =
44 let
45 rootSet = Set.fromList roots
46 rootMap = Map.restrictKeys mains rootSet
47 in
48 if Map.size rootMap == Set.size rootSet then
49 let
50 realMode = toRealMode mode target fields
51 state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap
52 in
53 Right $ stateToBuilder state <> toMainExports realMode interfaces rootMap
55 else
56 Left $ Set.toList $
57 Set.intersection rootSet (Map.keysSet mains)
60addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
61addMain mode graph home _ state =
62 addGlobal mode graph state (Opt.Global home "main")
65toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
66toRealMode mode target fields =
67 case mode of
68 Debug ->
69 Name.Debug target
71 Prod ->
72 Name.Prod target (Name.shortenFieldNames fields)
76-- GENERATE FOR REPL
79generateForRepl :: I.Interfaces -> Opt.Graph -> ModuleName.Canonical -> N.Name -> B.Builder
80generateForRepl interfaces (Opt.Graph _ graph _) home name =
81 let
82 mode = Name.Debug Name.Server
83 eval = addGlobal mode graph emptyState (Opt.Global home name)
84 in
85 stateToBuilder eval <> print interfaces home name
88print :: I.Interfaces -> ModuleName.Canonical -> N.Name -> B.Builder
89print interfaces home name =
90 let
91 value = Name.toBuilder (Name.fromGlobal home name)
92 toString = Name.toBuilder (Name.fromKernel N.debug "toString")
93 annotation = I._types (interfaces ! home) ! name
94 tipe = P.displayS (P.renderPretty 1.0 80 (Type.toDoc Type.None (Extract.fromAnnotation annotation))) ""
95 in
96 "var _value = " <> toString <> "(" <> value <> ");\n" <>
97 "var _type = '" <> B.stringUtf8 (show tipe) <> "';\n\
98 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
99 \ console.log(_value + '\\n : ' + _type.split('\\n').join('\\n '));\n\
100 \} else {\n\
101 \ console.log(_value + ' : ' + _type);\n\
102 \}\n"
106-- GRAPH TRAVERSAL STATE
109data State =
110 State
111 { _revBuilders :: [B.Builder]
112 , _seenGlobals :: Set.Set Opt.Global
113 }
116emptyState :: State
117emptyState =
118 State [] Set.empty
121stateToBuilder :: State -> B.Builder
122stateToBuilder (State revBuilders _) =
123 List.foldl1' (\builder b -> b <> builder) revBuilders
127-- ADD DEPENDENCIES
130type Graph = Map.Map Opt.Global Opt.Node
133addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
134addGlobal mode graph state@(State builders seen) global =
135 if Set.member global seen then
136 state
137 else
138 addGlobalHelp mode graph global $
139 State builders (Set.insert global seen)
142addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
143addGlobalHelp mode graph global state =
144 let
145 addDeps deps someState =
146 Set.foldl' (addGlobal mode graph) someState deps
147 in
148 case graph ! global of
149 Opt.Define expr deps ->
150 addStmt (addDeps deps state) (
151 var global (Expr.generate mode expr)
152 )
154 Opt.DefineTailFunc argNames body deps ->
155 addStmt (addDeps deps state) (
156 let (Opt.Global _ name) = global in
157 var global (Expr.generateTailDef mode name argNames body)
158 )
160 Opt.Ctor name index arity ->
161 addStmt state (
162 var global (Expr.generateCtor mode name index arity)
163 )
165 Opt.Link linkedGlobal ->
166 addGlobal mode graph state linkedGlobal
168 Opt.Cycle cycle deps ->
169 addStmt (addDeps deps state) (
170 generateCycle mode global cycle
171 )
173 Opt.Manager effectsType ->
174 generateManager mode graph global effectsType state
176 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
177 case maybeServer of
178 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
179 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
181 _ ->
182 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
184 Opt.Enum name index ->
185 addStmt state (
186 generateEnum mode global name index
187 )
189 Opt.Box name ->
190 addStmt state (
191 generateBox mode global name
192 )
194 Opt.PortIncoming decoder deps ->
195 addStmt (addDeps deps state) (
196 generatePort mode global "incomingPort" decoder
197 )
199 Opt.PortOutgoing encoder deps ->
200 addStmt (addDeps deps state) (
201 generatePort mode global "outgoingPort" encoder
202 )
205addStmt :: State -> JS.Stmt -> State
206addStmt state stmt =
207 addBuilder state (JS.stmtToBuilder stmt)
210addBuilder :: State -> B.Builder -> State
211addBuilder (State revBuilders seen) builder =
212 State (builder:revBuilders) seen
215var :: Opt.Global -> Expr.Code -> JS.Stmt
216var (Opt.Global home name) code =
217 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
221-- GENERATE CYCLES
224generateCycle :: Name.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 Name.Prod _ _ ->
233 block
235 Name.Debug _ ->
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 (H.makeLink "halting-problem")
241 <> " to learn how to fix it!"
244generateSafeCycle :: Name.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 :: Name.Mode -> [Opt.KChunk] -> B.Builder
280generateKernel mode chunks =
281 List.foldl' (addChunk mode) mempty chunks
284addChunk :: Name.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 (Name.fromField 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 Name.Debug _ ->
308 builder
310 Name.Prod _ _ ->
311 "_UNUSED" <> builder
313 Opt.Prod ->
314 case mode of
315 Name.Debug _ ->
316 "_UNUSED" <> builder
318 Name.Prod _ _ ->
319 builder
323-- GENERATE ENUM
326generateEnum :: Name.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 Name.Debug _ ->
332 Expr.codeToExpr (Expr.generateCtor mode ctorName index 0)
334 Name.Prod _ _ ->
335 JS.Int (Index.toMachine index)
336 in
337 JS.Var [ (Name.fromGlobal home name, Just definition) ]
341-- GENERATE BOX
344generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
345generateBox mode (Opt.Global home name) ctorName =
346 let
347 definition =
348 case mode of
349 Name.Debug _ ->
350 Expr.codeToExpr (Expr.generateCtor mode ctorName Index.first 1)
352 Name.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 :: Name.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 :: Name.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 :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
445toMainExports mode interfaces mains =
446 let
447 export =
448 Name.fromKernel N.platform "export"
450 exports =
451 generateExports mode interfaces $
452 Map.foldrWithKey addToTrie emptyTrie mains
453 in
454 Name.toBuilder export <> "(" <> exports <> ");"
457generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
458generateExports mode interfaces (Trie maybeMain subs) =
459 let
460 object =
461 case Map.toList subs of
462 [] ->
463 "{}"
465 (name, subTrie) : otherSubTries ->
466 "{'" <> Text.encodeUtf8Builder name <> "':"
467 <> generateExports mode interfaces subTrie
468 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
469 in
470 case maybeMain of
471 Nothing ->
472 object
474 Just (home, main) ->
475 let initialize = Expr.generateMain mode interfaces home main in
476 JS.exprToBuilder initialize <> "(" <> object <> ")"
479addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (Text.Text, Trie) -> B.Builder
480addSubTrie mode interfaces end (name, trie) =
481 ",'" <> Text.encodeUtf8Builder name <> "':"
482 <> generateExports mode interfaces trie
483 <> end
487-- BUILD TRIES
490data Trie =
491 Trie
492 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
493 , _subs :: Map.Map Text.Text Trie
494 }
497emptyTrie :: Trie
498emptyTrie =
499 Trie Nothing Map.empty
502addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
503addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
504 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
507segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
508segmentsToTrie home segments main =
509 case segments of
510 [] ->
511 Trie (Just (home, main)) Map.empty
513 segment : otherSegments ->
514 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
517merge :: Trie -> Trie -> Trie
518merge (Trie main1 subs1) (Trie main2 subs2) =
519 Trie
520 (checkedMerge main1 main2)
521 (Map.unionWith merge subs1 subs2)
524checkedMerge :: Maybe a -> Maybe a -> Maybe a
525checkedMerge a b =
526 case (a, b) of
527 (Nothing, main) ->
528 main
530 (main, Nothing) ->
531 main
533 (Just _, Just _) ->
534 error "cannot have two modules with the same name"