git.iko.soy/elk
on 78cd7e7 help sign in
elk/compiler/src/Generate/JavaScript.hs
543 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 = Prod | Dev | Debug
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 Debug ->
75 Name.Dev target Name.DebuggerOn
77 Dev ->
78 Name.Dev target Name.DebuggerOff
80 Prod ->
81 Name.Prod target (Name.shortenFieldNames fields)
85-- GENERATE FOR REPL
88generateForRepl :: Opt.Graph -> I.Interface -> ModuleName.Canonical -> N.Name -> B.Builder
89generateForRepl (Opt.Graph _ graph _) iface home name =
90 let
91 mode = Name.Dev Name.Server Name.DebuggerOff
92 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
93 evalState = addGlobal mode graph debugState (Opt.Global home name)
94 in
95 stateToBuilder evalState <> print home name (I._types iface ! name)
98print :: ModuleName.Canonical -> N.Name -> Can.Annotation -> B.Builder
99print home name annotation =
100 let
101 value = Name.toBuilder (Name.fromGlobal home name)
102 toString = Name.toBuilder (Name.fromKernel N.debug "toString")
103 tipe = Type.toDoc Type.None (Extract.fromAnnotation annotation)
104 in
105 "var _value = " <> toString <> "(" <> value <> ");\n" <>
106 "var _type = " <> B.stringUtf8 (show (D.toString tipe)) <> ";\n\
107 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
108 \ console.log(_value + '\\n : ' + _type.split('\\n').join('\\n '));\n\
109 \} else {\n\
110 \ console.log(_value + ' : ' + _type);\n\
111 \}\n"
115-- GRAPH TRAVERSAL STATE
118data State =
119 State
120 { _revBuilders :: [B.Builder]
121 , _seenGlobals :: Set.Set Opt.Global
122 }
125emptyState :: State
126emptyState =
127 State [] Set.empty
130stateToBuilder :: State -> B.Builder
131stateToBuilder (State revBuilders _) =
132 List.foldl1' (\builder b -> b <> builder) revBuilders
136-- ADD DEPENDENCIES
139type Graph = Map.Map Opt.Global Opt.Node
142addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
143addGlobal mode graph state@(State builders seen) global =
144 if Set.member global seen then
145 state
146 else
147 addGlobalHelp mode graph global $
148 State builders (Set.insert global seen)
151addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
152addGlobalHelp mode graph global state =
153 let
154 addDeps deps someState =
155 Set.foldl' (addGlobal mode graph) someState deps
156 in
157 case graph ! global of
158 Opt.Define expr deps ->
159 addStmt (addDeps deps state) (
160 var global (Expr.generate mode expr)
161 )
163 Opt.DefineTailFunc argNames body deps ->
164 addStmt (addDeps deps state) (
165 let (Opt.Global _ name) = global in
166 var global (Expr.generateTailDef mode name argNames body)
167 )
169 Opt.Ctor name index arity ->
170 addStmt state (
171 var global (Expr.generateCtor mode name index arity)
172 )
174 Opt.Link linkedGlobal ->
175 addGlobal mode graph state linkedGlobal
177 Opt.Cycle cycle deps ->
178 addStmt (addDeps deps state) (
179 generateCycle mode global cycle
180 )
182 Opt.Manager effectsType ->
183 generateManager mode graph global effectsType state
185 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
186 case maybeServer of
187 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
188 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
190 _ ->
191 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
193 Opt.Enum name index ->
194 addStmt state (
195 generateEnum mode global name index
196 )
198 Opt.Box name ->
199 addStmt state (
200 generateBox mode global name
201 )
203 Opt.PortIncoming decoder deps ->
204 addStmt (addDeps deps state) (
205 generatePort mode global "incomingPort" decoder
206 )
208 Opt.PortOutgoing encoder deps ->
209 addStmt (addDeps deps state) (
210 generatePort mode global "outgoingPort" encoder
211 )
214addStmt :: State -> JS.Stmt -> State
215addStmt state stmt =
216 addBuilder state (JS.stmtToBuilder stmt)
219addBuilder :: State -> B.Builder -> State
220addBuilder (State revBuilders seen) builder =
221 State (builder:revBuilders) seen
224var :: Opt.Global -> Expr.Code -> JS.Stmt
225var (Opt.Global home name) code =
226 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
230-- GENERATE CYCLES
233generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
234generateCycle mode (Opt.Global home _) cycle =
235 let
236 safeDefs = map (generateSafeCycle mode home) cycle
237 realDefs = map (generateRealCycle home) cycle
238 block = JS.Block (safeDefs ++ realDefs)
239 in
240 case mode of
241 Name.Prod _ _ ->
242 block
244 Name.Dev _ _ ->
245 JS.Try block Name.dollar $ JS.Throw $ JS.String $
246 "The following top-level definitions are causing infinite recursion:\\n"
247 <> drawCycle (map fst cycle)
248 <> "\\n\\nThese errors are very tricky, so read "
249 <> B.stringUtf8 (D.makeLink "halting-problem")
250 <> " to learn how to fix it!"
253generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
254generateSafeCycle mode home (name, expr) =
255 JS.FunctionStmt (Name.fromCycle home name) [] $
256 Expr.codeToStmtList (Expr.generate mode expr)
259generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
260generateRealCycle home (name, _) =
261 let
262 safeName = Name.fromCycle home name
263 realName = Name.fromGlobal home name
264 in
265 JS.Block
266 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
267 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
268 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
269 ]
272drawCycle :: [N.Name] -> B.Builder
273drawCycle names =
274 let
275 topLine = "\\n ┌─────┐"
276 nameLine name = "\\n │ " <> N.toBuilder name
277 midLine = "\\n │ ↓"
278 bottomLine = "\\n └─────┘"
279 in
280 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
285-- GENERATE KERNEL
288generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
289generateKernel mode chunks =
290 List.foldl' (addChunk mode) mempty chunks
293addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
294addChunk mode builder chunk =
295 case chunk of
296 Opt.JS javascript ->
297 B.byteString javascript <> builder
299 Opt.ElmVar home name ->
300 Name.toBuilder (Name.fromGlobal home name) <> builder
302 Opt.JsVar home name ->
303 Name.toBuilder (Name.fromKernel home name) <> builder
305 Opt.ElmField name ->
306 Name.toBuilder (Name.fromField mode name) <> builder
308 Opt.JsField int ->
309 Name.toBuilder (Name.fromInt int) <> builder
311 Opt.JsEnum int ->
312 B.intDec int <> builder
314 Opt.Debug ->
315 case mode of
316 Name.Dev _ _ ->
317 builder
319 Name.Prod _ _ ->
320 "_UNUSED" <> builder
322 Opt.Prod ->
323 case mode of
324 Name.Dev _ _ ->
325 "_UNUSED" <> builder
327 Name.Prod _ _ ->
328 builder
332-- GENERATE ENUM
335generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
336generateEnum mode (Opt.Global home name) ctorName index =
337 let
338 definition =
339 case mode of
340 Name.Dev _ _ ->
341 Expr.codeToExpr (Expr.generateCtor mode ctorName index 0)
343 Name.Prod _ _ ->
344 JS.Int (Index.toMachine index)
345 in
346 JS.Var [ (Name.fromGlobal home name, Just definition) ]
350-- GENERATE BOX
353generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
354generateBox mode (Opt.Global home name) ctorName =
355 let
356 definition =
357 case mode of
358 Name.Dev _ _ ->
359 Expr.codeToExpr (Expr.generateCtor mode ctorName Index.first 1)
361 Name.Prod _ _ ->
362 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
363 in
364 JS.Var [ (Name.fromGlobal home name, Just definition) ]
368-- GENERATE PORTS
371generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
372generatePort mode (Opt.Global home name) makePort converter =
373 let
374 definition =
375 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
376 [ JS.String (N.toBuilder name)
377 , Expr.codeToExpr (Expr.generate mode converter)
378 ]
379 in
380 JS.Var [ (Name.fromGlobal home name, Just definition) ]
384-- GENERATE MANAGER
387generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
388generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
389 let
390 managerLVar =
391 JS.LBracket
392 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
393 (JS.String (N.toBuilder moduleName))
395 (deps, args, stmts) =
396 generateManagerHelp home effectsType
398 createManager =
399 JS.ExprStmt $ JS.Assign managerLVar $
400 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
401 in
402 addStmt (List.foldl' (addGlobal mode graph) state deps) $
403 JS.Block (createManager : stmts)
406generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
407generateLeaf home@(ModuleName.Canonical _ moduleName) name =
408 let
409 definition =
410 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
411 in
412 JS.Var [ (Name.fromGlobal home name, Just definition) ]
415{-# NOINLINE leaf #-}
416leaf :: JS.Expr
417leaf =
418 JS.Ref (Name.fromKernel N.platform "leaf")
421generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
422generateManagerHelp home effectsType =
423 let
424 dep name = Opt.Global home name
425 ref name = JS.Ref (Name.fromGlobal home name)
426 in
427 case effectsType of
428 Opt.Cmd ->
429 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
430 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
431 , [ generateLeaf home "command" ]
432 )
434 Opt.Sub ->
435 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
436 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
437 , [ generateLeaf home "subscription" ]
438 )
440 Opt.Fx ->
441 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
442 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
443 , [ generateLeaf home "command"
444 , generateLeaf home "subscription"
445 ]
446 )
450-- MAIN EXPORTS
453toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
454toMainExports mode interfaces mains =
455 let
456 export =
457 Name.fromKernel N.platform "export"
459 exports =
460 generateExports mode interfaces $
461 Map.foldrWithKey addToTrie emptyTrie mains
462 in
463 Name.toBuilder export <> "(" <> exports <> ");"
466generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
467generateExports mode interfaces (Trie maybeMain subs) =
468 let
469 object =
470 case Map.toList subs of
471 [] ->
472 "{}"
474 (name, subTrie) : otherSubTries ->
475 "{'" <> Text.encodeUtf8Builder name <> "':"
476 <> generateExports mode interfaces subTrie
477 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
478 in
479 case maybeMain of
480 Nothing ->
481 object
483 Just (home, main) ->
484 let initialize = Expr.generateMain mode interfaces home main in
485 JS.exprToBuilder initialize <> "(" <> object <> ")"
488addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (Text.Text, Trie) -> B.Builder
489addSubTrie mode interfaces end (name, trie) =
490 ",'" <> Text.encodeUtf8Builder name <> "':"
491 <> generateExports mode interfaces trie
492 <> end
496-- BUILD TRIES
499data Trie =
500 Trie
501 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
502 , _subs :: Map.Map Text.Text Trie
503 }
506emptyTrie :: Trie
507emptyTrie =
508 Trie Nothing Map.empty
511addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
512addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
513 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
516segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
517segmentsToTrie home segments main =
518 case segments of
519 [] ->
520 Trie (Just (home, main)) Map.empty
522 segment : otherSegments ->
523 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
526merge :: Trie -> Trie -> Trie
527merge (Trie main1 subs1) (Trie main2 subs2) =
528 Trie
529 (checkedMerge main1 main2)
530 (Map.unionWith merge subs1 subs2)
533checkedMerge :: Maybe a -> Maybe a -> Maybe a
534checkedMerge a b =
535 case (a, b) of
536 (Nothing, main) ->
537 main
539 (main, Nothing) ->
540 main
542 (Just _, Just _) ->
543 error "cannot have two modules with the same name"