git.iko.soy/elk
on 2d4371e help sign in
elk/compiler/src/Generate/JavaScript.hs
541 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
20import qualified Text.PrettyPrint.ANSI.Leijen as P
22import qualified AST.Canonical as Can
23import qualified AST.Optimized as Opt
24import qualified AST.Module.Name as ModuleName
25import qualified Data.Index as Index
26import qualified Elm.Compiler.Type as Type
27import qualified Elm.Compiler.Type.Extract as Extract
28import qualified Elm.Interface as I
29import qualified Elm.Name as N
30import qualified Generate.JavaScript.Builder as JS
31import qualified Generate.JavaScript.Expression as Expr
32import qualified Generate.JavaScript.Name as Name
33import qualified Reporting.Helpers as H
37-- GENERATE MAINS
40data Mode = Dev | Prod
43data Output
44 = None
45 | Some N.Name [N.Name] B.Builder
48generate :: Mode -> Name.Target -> I.Interfaces -> Opt.Graph -> [ModuleName.Canonical] -> Output
49generate mode target interfaces (Opt.Graph mains graph fields) roots =
50 let
51 rootSet = Set.fromList roots
52 rootMap = Map.restrictKeys mains rootSet
53 in
54 case map ModuleName._module (Map.keys rootMap) of
55 [] ->
56 None
58 name:names ->
59 let
60 realMode = toRealMode mode target fields
61 state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap
62 builder = stateToBuilder state <> toMainExports realMode interfaces rootMap
63 in
64 Some name names builder
67addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
68addMain mode graph home _ state =
69 addGlobal mode graph state (Opt.Global home "main")
72toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
73toRealMode mode target fields =
74 case mode of
75 Dev ->
76 Name.Dev target
78 Prod ->
79 Name.Prod target (Name.shortenFieldNames fields)
83-- GENERATE FOR REPL
86generateForRepl :: Opt.Graph -> I.Interface -> ModuleName.Canonical -> N.Name -> B.Builder
87generateForRepl (Opt.Graph _ graph _) iface home name =
88 let
89 mode = Name.Dev Name.Server
90 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
91 evalState = addGlobal mode graph debugState (Opt.Global home name)
92 in
93 stateToBuilder evalState <> print home name (I._types iface ! name)
96print :: ModuleName.Canonical -> N.Name -> Can.Annotation -> B.Builder
97print home name annotation =
98 let
99 value = Name.toBuilder (Name.fromGlobal home name)
100 toString = Name.toBuilder (Name.fromKernel N.debug "toString")
101 tipe = P.displayS (P.renderPretty 1.0 80 (Type.toDoc Type.None (Extract.fromAnnotation annotation))) ""
102 in
103 "var _value = " <> toString <> "(" <> value <> ");\n" <>
104 "var _type = " <> B.stringUtf8 (show tipe) <> ";\n\
105 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
106 \ console.log(_value + '\\n : ' + _type.split('\\n').join('\\n '));\n\
107 \} else {\n\
108 \ console.log(_value + ' : ' + _type);\n\
109 \}\n"
113-- GRAPH TRAVERSAL STATE
116data State =
117 State
118 { _revBuilders :: [B.Builder]
119 , _seenGlobals :: Set.Set Opt.Global
120 }
123emptyState :: State
124emptyState =
125 State [] Set.empty
128stateToBuilder :: State -> B.Builder
129stateToBuilder (State revBuilders _) =
130 List.foldl1' (\builder b -> b <> builder) revBuilders
134-- ADD DEPENDENCIES
137type Graph = Map.Map Opt.Global Opt.Node
140addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
141addGlobal mode graph state@(State builders seen) global =
142 if Set.member global seen then
143 state
144 else
145 addGlobalHelp mode graph global $
146 State builders (Set.insert global seen)
149addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
150addGlobalHelp mode graph global state =
151 let
152 addDeps deps someState =
153 Set.foldl' (addGlobal mode graph) someState deps
154 in
155 case graph ! global of
156 Opt.Define expr deps ->
157 addStmt (addDeps deps state) (
158 var global (Expr.generate mode expr)
159 )
161 Opt.DefineTailFunc argNames body deps ->
162 addStmt (addDeps deps state) (
163 let (Opt.Global _ name) = global in
164 var global (Expr.generateTailDef mode name argNames body)
165 )
167 Opt.Ctor name index arity ->
168 addStmt state (
169 var global (Expr.generateCtor mode name index arity)
170 )
172 Opt.Link linkedGlobal ->
173 addGlobal mode graph state linkedGlobal
175 Opt.Cycle cycle deps ->
176 addStmt (addDeps deps state) (
177 generateCycle mode global cycle
178 )
180 Opt.Manager effectsType ->
181 generateManager mode graph global effectsType state
183 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
184 case maybeServer of
185 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
186 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
188 _ ->
189 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
191 Opt.Enum name index ->
192 addStmt state (
193 generateEnum mode global name index
194 )
196 Opt.Box name ->
197 addStmt state (
198 generateBox mode global name
199 )
201 Opt.PortIncoming decoder deps ->
202 addStmt (addDeps deps state) (
203 generatePort mode global "incomingPort" decoder
204 )
206 Opt.PortOutgoing encoder deps ->
207 addStmt (addDeps deps state) (
208 generatePort mode global "outgoingPort" encoder
209 )
212addStmt :: State -> JS.Stmt -> State
213addStmt state stmt =
214 addBuilder state (JS.stmtToBuilder stmt)
217addBuilder :: State -> B.Builder -> State
218addBuilder (State revBuilders seen) builder =
219 State (builder:revBuilders) seen
222var :: Opt.Global -> Expr.Code -> JS.Stmt
223var (Opt.Global home name) code =
224 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
228-- GENERATE CYCLES
231generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
232generateCycle mode (Opt.Global home _) cycle =
233 let
234 safeDefs = map (generateSafeCycle mode home) cycle
235 realDefs = map (generateRealCycle home) cycle
236 block = JS.Block (safeDefs ++ realDefs)
237 in
238 case mode of
239 Name.Prod _ _ ->
240 block
242 Name.Dev _ ->
243 JS.Try block Name.dollar $ JS.Throw $ JS.String $
244 "The following top-level definitions are causing infinite recursion:\\n"
245 <> drawCycle (map fst cycle)
246 <> "\\n\\nThese errors are very tricky, so read "
247 <> B.stringUtf8 (H.makeLink "halting-problem")
248 <> " to learn how to fix it!"
251generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
252generateSafeCycle mode home (name, expr) =
253 JS.FunctionStmt (Name.fromCycle home name) [] $
254 Expr.codeToStmtList (Expr.generate mode expr)
257generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
258generateRealCycle home (name, _) =
259 let
260 safeName = Name.fromCycle home name
261 realName = Name.fromGlobal home name
262 in
263 JS.Block
264 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
265 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
266 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
267 ]
270drawCycle :: [N.Name] -> B.Builder
271drawCycle names =
272 let
273 topLine = "\\n ┌─────┐"
274 nameLine name = "\\n │ " <> N.toBuilder name
275 midLine = "\\n │ ↓"
276 bottomLine = "\\n └─────┘"
277 in
278 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
283-- GENERATE KERNEL
286generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
287generateKernel mode chunks =
288 List.foldl' (addChunk mode) mempty chunks
291addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
292addChunk mode builder chunk =
293 case chunk of
294 Opt.JS javascript ->
295 B.byteString javascript <> builder
297 Opt.ElmVar home name ->
298 Name.toBuilder (Name.fromGlobal home name) <> builder
300 Opt.JsVar home name ->
301 Name.toBuilder (Name.fromKernel home name) <> builder
303 Opt.ElmField name ->
304 Name.toBuilder (Name.fromField mode name) <> builder
306 Opt.JsField int ->
307 Name.toBuilder (Name.fromInt int) <> builder
309 Opt.JsEnum int ->
310 B.intDec int <> builder
312 Opt.Debug ->
313 case mode of
314 Name.Dev _ ->
315 builder
317 Name.Prod _ _ ->
318 "_UNUSED" <> builder
320 Opt.Prod ->
321 case mode of
322 Name.Dev _ ->
323 "_UNUSED" <> builder
325 Name.Prod _ _ ->
326 builder
330-- GENERATE ENUM
333generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
334generateEnum mode (Opt.Global home name) ctorName index =
335 let
336 definition =
337 case mode of
338 Name.Dev _ ->
339 Expr.codeToExpr (Expr.generateCtor mode ctorName index 0)
341 Name.Prod _ _ ->
342 JS.Int (Index.toMachine index)
343 in
344 JS.Var [ (Name.fromGlobal home name, Just definition) ]
348-- GENERATE BOX
351generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
352generateBox mode (Opt.Global home name) ctorName =
353 let
354 definition =
355 case mode of
356 Name.Dev _ ->
357 Expr.codeToExpr (Expr.generateCtor mode ctorName Index.first 1)
359 Name.Prod _ _ ->
360 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
361 in
362 JS.Var [ (Name.fromGlobal home name, Just definition) ]
366-- GENERATE PORTS
369generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
370generatePort mode (Opt.Global home name) makePort converter =
371 let
372 definition =
373 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
374 [ JS.String (N.toBuilder name)
375 , Expr.codeToExpr (Expr.generate mode converter)
376 ]
377 in
378 JS.Var [ (Name.fromGlobal home name, Just definition) ]
382-- GENERATE MANAGER
385generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
386generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
387 let
388 managerLVar =
389 JS.LBracket
390 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
391 (JS.String (N.toBuilder moduleName))
393 (deps, args, stmts) =
394 generateManagerHelp home effectsType
396 createManager =
397 JS.ExprStmt $ JS.Assign managerLVar $
398 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
399 in
400 addStmt (List.foldl' (addGlobal mode graph) state deps) $
401 JS.Block (createManager : stmts)
404generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
405generateLeaf home@(ModuleName.Canonical _ moduleName) name =
406 let
407 definition =
408 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
409 in
410 JS.Var [ (Name.fromGlobal home name, Just definition) ]
413{-# NOINLINE leaf #-}
414leaf :: JS.Expr
415leaf =
416 JS.Ref (Name.fromKernel N.platform "leaf")
419generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
420generateManagerHelp home effectsType =
421 let
422 dep name = Opt.Global home name
423 ref name = JS.Ref (Name.fromGlobal home name)
424 in
425 case effectsType of
426 Opt.Cmd ->
427 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
428 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
429 , [ generateLeaf home "command" ]
430 )
432 Opt.Sub ->
433 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
434 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
435 , [ generateLeaf home "subscription" ]
436 )
438 Opt.Fx ->
439 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
440 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
441 , [ generateLeaf home "command"
442 , generateLeaf home "subscription"
443 ]
444 )
448-- MAIN EXPORTS
451toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
452toMainExports mode interfaces mains =
453 let
454 export =
455 Name.fromKernel N.platform "export"
457 exports =
458 generateExports mode interfaces $
459 Map.foldrWithKey addToTrie emptyTrie mains
460 in
461 Name.toBuilder export <> "(" <> exports <> ");"
464generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
465generateExports mode interfaces (Trie maybeMain subs) =
466 let
467 object =
468 case Map.toList subs of
469 [] ->
470 "{}"
472 (name, subTrie) : otherSubTries ->
473 "{'" <> Text.encodeUtf8Builder name <> "':"
474 <> generateExports mode interfaces subTrie
475 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
476 in
477 case maybeMain of
478 Nothing ->
479 object
481 Just (home, main) ->
482 let initialize = Expr.generateMain mode interfaces home main in
483 JS.exprToBuilder initialize <> "(" <> object <> ")"
486addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (Text.Text, Trie) -> B.Builder
487addSubTrie mode interfaces end (name, trie) =
488 ",'" <> Text.encodeUtf8Builder name <> "':"
489 <> generateExports mode interfaces trie
490 <> end
494-- BUILD TRIES
497data Trie =
498 Trie
499 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
500 , _subs :: Map.Map Text.Text Trie
501 }
504emptyTrie :: Trie
505emptyTrie =
506 Trie Nothing Map.empty
509addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
510addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
511 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
514segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
515segmentsToTrie home segments main =
516 case segments of
517 [] ->
518 Trie (Just (home, main)) Map.empty
520 segment : otherSegments ->
521 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
524merge :: Trie -> Trie -> Trie
525merge (Trie main1 subs1) (Trie main2 subs2) =
526 Trie
527 (checkedMerge main1 main2)
528 (Map.unionWith merge subs1 subs2)
531checkedMerge :: Maybe a -> Maybe a -> Maybe a
532checkedMerge a b =
533 case (a, b) of
534 (Nothing, main) ->
535 main
537 (main, Nothing) ->
538 main
540 (Just _, Just _) ->
541 error "cannot have two modules with the same name"