git.iko.soy/elk
on 45bdd0d help sign in
elk/compiler/src/Generate/JavaScript.hs
532 lines 14 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript
3 ( Mode(..)
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
19import qualified Text.PrettyPrint.ANSI.Leijen as P
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.Helpers as H
36-- GENERATE MAINS
39data Mode = Debug | Prod
42generate :: Mode -> Name.Target -> I.Interfaces -> Opt.Graph -> [ModuleName.Canonical] -> Maybe 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.null rootMap then
49 Nothing
50 else
51 let
52 realMode = toRealMode mode target fields
53 state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap
54 in
55 Just $ stateToBuilder state <> toMainExports realMode interfaces rootMap
58addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
59addMain mode graph home _ state =
60 addGlobal mode graph state (Opt.Global home "main")
63toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
64toRealMode mode target fields =
65 case mode of
66 Debug ->
67 Name.Debug target
69 Prod ->
70 Name.Prod target (Name.shortenFieldNames fields)
74-- GENERATE FOR REPL
77generateForRepl :: Opt.Graph -> I.Interface -> ModuleName.Canonical -> N.Name -> B.Builder
78generateForRepl (Opt.Graph _ graph _) iface home name =
79 let
80 mode = Name.Debug Name.Server
81 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
82 evalState = addGlobal mode graph debugState (Opt.Global home name)
83 in
84 stateToBuilder evalState <> print home name (I._types iface ! name)
87print :: ModuleName.Canonical -> N.Name -> Can.Annotation -> B.Builder
88print home name annotation =
89 let
90 value = Name.toBuilder (Name.fromGlobal home name)
91 toString = Name.toBuilder (Name.fromKernel N.debug "toString")
92 tipe = P.displayS (P.renderPretty 1.0 80 (Type.toDoc Type.None (Extract.fromAnnotation annotation))) ""
93 in
94 "var _value = " <> toString <> "(" <> value <> ");\n" <>
95 "var _type = " <> B.stringUtf8 (show tipe) <> ";\n\
96 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
97 \ console.log(_value + '\\n : ' + _type.split('\\n').join('\\n '));\n\
98 \} else {\n\
99 \ console.log(_value + ' : ' + _type);\n\
100 \}\n"
104-- GRAPH TRAVERSAL STATE
107data State =
108 State
109 { _revBuilders :: [B.Builder]
110 , _seenGlobals :: Set.Set Opt.Global
111 }
114emptyState :: State
115emptyState =
116 State [] Set.empty
119stateToBuilder :: State -> B.Builder
120stateToBuilder (State revBuilders _) =
121 List.foldl1' (\builder b -> b <> builder) revBuilders
125-- ADD DEPENDENCIES
128type Graph = Map.Map Opt.Global Opt.Node
131addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
132addGlobal mode graph state@(State builders seen) global =
133 if Set.member global seen then
134 state
135 else
136 addGlobalHelp mode graph global $
137 State builders (Set.insert global seen)
140addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
141addGlobalHelp mode graph global state =
142 let
143 addDeps deps someState =
144 Set.foldl' (addGlobal mode graph) someState deps
145 in
146 case graph ! global of
147 Opt.Define expr deps ->
148 addStmt (addDeps deps state) (
149 var global (Expr.generate mode expr)
150 )
152 Opt.DefineTailFunc argNames body deps ->
153 addStmt (addDeps deps state) (
154 let (Opt.Global _ name) = global in
155 var global (Expr.generateTailDef mode name argNames body)
156 )
158 Opt.Ctor name index arity ->
159 addStmt state (
160 var global (Expr.generateCtor mode name index arity)
161 )
163 Opt.Link linkedGlobal ->
164 addGlobal mode graph state linkedGlobal
166 Opt.Cycle cycle deps ->
167 addStmt (addDeps deps state) (
168 generateCycle mode global cycle
169 )
171 Opt.Manager effectsType ->
172 generateManager mode graph global effectsType state
174 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
175 case maybeServer of
176 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
177 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
179 _ ->
180 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
182 Opt.Enum name index ->
183 addStmt state (
184 generateEnum mode global name index
185 )
187 Opt.Box name ->
188 addStmt state (
189 generateBox mode global name
190 )
192 Opt.PortIncoming decoder deps ->
193 addStmt (addDeps deps state) (
194 generatePort mode global "incomingPort" decoder
195 )
197 Opt.PortOutgoing encoder deps ->
198 addStmt (addDeps deps state) (
199 generatePort mode global "outgoingPort" encoder
200 )
203addStmt :: State -> JS.Stmt -> State
204addStmt state stmt =
205 addBuilder state (JS.stmtToBuilder stmt)
208addBuilder :: State -> B.Builder -> State
209addBuilder (State revBuilders seen) builder =
210 State (builder:revBuilders) seen
213var :: Opt.Global -> Expr.Code -> JS.Stmt
214var (Opt.Global home name) code =
215 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
219-- GENERATE CYCLES
222generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
223generateCycle mode (Opt.Global home _) cycle =
224 let
225 safeDefs = map (generateSafeCycle mode home) cycle
226 realDefs = map (generateRealCycle home) cycle
227 block = JS.Block (safeDefs ++ realDefs)
228 in
229 case mode of
230 Name.Prod _ _ ->
231 block
233 Name.Debug _ ->
234 JS.Try block Name.dollar $ JS.Throw $ JS.String $
235 "The following top-level definitions are causing infinite recursion:\\n"
236 <> drawCycle (map fst cycle)
237 <> "\\n\\nThese errors are very tricky, so read "
238 <> B.stringUtf8 (H.makeLink "halting-problem")
239 <> " to learn how to fix it!"
242generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
243generateSafeCycle mode home (name, expr) =
244 JS.FunctionStmt (Name.fromCycle home name) [] $
245 Expr.codeToStmtList (Expr.generate mode expr)
248generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
249generateRealCycle home (name, _) =
250 let
251 safeName = Name.fromCycle home name
252 realName = Name.fromGlobal home name
253 in
254 JS.Block
255 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
256 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
257 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
258 ]
261drawCycle :: [N.Name] -> B.Builder
262drawCycle names =
263 let
264 topLine = "\\n ┌─────┐"
265 nameLine name = "\\n │ " <> N.toBuilder name
266 midLine = "\\n │ ↓"
267 bottomLine = "\\n └─────┘"
268 in
269 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
274-- GENERATE KERNEL
277generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
278generateKernel mode chunks =
279 List.foldl' (addChunk mode) mempty chunks
282addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
283addChunk mode builder chunk =
284 case chunk of
285 Opt.JS javascript ->
286 B.byteString javascript <> builder
288 Opt.ElmVar home name ->
289 Name.toBuilder (Name.fromGlobal home name) <> builder
291 Opt.JsVar home name ->
292 Name.toBuilder (Name.fromKernel home name) <> builder
294 Opt.ElmField name ->
295 Name.toBuilder (Name.fromField mode name) <> builder
297 Opt.JsField int ->
298 Name.toBuilder (Name.fromInt int) <> builder
300 Opt.JsEnum int ->
301 B.intDec int <> builder
303 Opt.Debug ->
304 case mode of
305 Name.Debug _ ->
306 builder
308 Name.Prod _ _ ->
309 "_UNUSED" <> builder
311 Opt.Prod ->
312 case mode of
313 Name.Debug _ ->
314 "_UNUSED" <> builder
316 Name.Prod _ _ ->
317 builder
321-- GENERATE ENUM
324generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
325generateEnum mode (Opt.Global home name) ctorName index =
326 let
327 definition =
328 case mode of
329 Name.Debug _ ->
330 Expr.codeToExpr (Expr.generateCtor mode ctorName index 0)
332 Name.Prod _ _ ->
333 JS.Int (Index.toMachine index)
334 in
335 JS.Var [ (Name.fromGlobal home name, Just definition) ]
339-- GENERATE BOX
342generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
343generateBox mode (Opt.Global home name) ctorName =
344 let
345 definition =
346 case mode of
347 Name.Debug _ ->
348 Expr.codeToExpr (Expr.generateCtor mode ctorName Index.first 1)
350 Name.Prod _ _ ->
351 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
352 in
353 JS.Var [ (Name.fromGlobal home name, Just definition) ]
357-- GENERATE PORTS
360generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
361generatePort mode (Opt.Global home name) makePort converter =
362 let
363 definition =
364 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
365 [ JS.String (N.toBuilder name)
366 , Expr.codeToExpr (Expr.generate mode converter)
367 ]
368 in
369 JS.Var [ (Name.fromGlobal home name, Just definition) ]
373-- GENERATE MANAGER
376generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
377generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
378 let
379 managerLVar =
380 JS.LBracket
381 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
382 (JS.String (N.toBuilder moduleName))
384 (deps, args, stmts) =
385 generateManagerHelp home effectsType
387 createManager =
388 JS.ExprStmt $ JS.Assign managerLVar $
389 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
390 in
391 addStmt (List.foldl' (addGlobal mode graph) state deps) $
392 JS.Block (createManager : stmts)
395generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
396generateLeaf home@(ModuleName.Canonical _ moduleName) name =
397 let
398 definition =
399 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
400 in
401 JS.Var [ (Name.fromGlobal home name, Just definition) ]
404{-# NOINLINE leaf #-}
405leaf :: JS.Expr
406leaf =
407 JS.Ref (Name.fromKernel N.platform "leaf")
410generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
411generateManagerHelp home effectsType =
412 let
413 dep name = Opt.Global home name
414 ref name = JS.Ref (Name.fromGlobal home name)
415 in
416 case effectsType of
417 Opt.Cmd ->
418 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
419 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
420 , [ generateLeaf home "command" ]
421 )
423 Opt.Sub ->
424 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
425 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
426 , [ generateLeaf home "subscription" ]
427 )
429 Opt.Fx ->
430 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
431 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
432 , [ generateLeaf home "command"
433 , generateLeaf home "subscription"
434 ]
435 )
439-- MAIN EXPORTS
442toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
443toMainExports mode interfaces mains =
444 let
445 export =
446 Name.fromKernel N.platform "export"
448 exports =
449 generateExports mode interfaces $
450 Map.foldrWithKey addToTrie emptyTrie mains
451 in
452 Name.toBuilder export <> "(" <> exports <> ");"
455generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
456generateExports mode interfaces (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 interfaces subTrie
466 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
467 in
468 case maybeMain of
469 Nothing ->
470 object
472 Just (home, main) ->
473 let initialize = Expr.generateMain mode interfaces home main in
474 JS.exprToBuilder initialize <> "(" <> object <> ")"
477addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (Text.Text, Trie) -> B.Builder
478addSubTrie mode interfaces end (name, trie) =
479 ",'" <> Text.encodeUtf8Builder name <> "':"
480 <> generateExports mode interfaces trie
481 <> end
485-- BUILD TRIES
488data Trie =
489 Trie
490 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
491 , _subs :: Map.Map Text.Text Trie
492 }
495emptyTrie :: Trie
496emptyTrie =
497 Trie Nothing Map.empty
500addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
501addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
502 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
505segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
506segmentsToTrie home segments main =
507 case segments of
508 [] ->
509 Trie (Just (home, main)) Map.empty
511 segment : otherSegments ->
512 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
515merge :: Trie -> Trie -> Trie
516merge (Trie main1 subs1) (Trie main2 subs2) =
517 Trie
518 (checkedMerge main1 main2)
519 (Map.unionWith merge subs1 subs2)
522checkedMerge :: Maybe a -> Maybe a -> Maybe a
523checkedMerge a b =
524 case (a, b) of
525 (Nothing, main) ->
526 main
528 (main, Nothing) ->
529 main
531 (Just _, Just _) ->
532 error "cannot have two modules with the same name"