git.iko.soy/elk
on 2b0bc09 help sign in
elk/compiler/src/Generate/JavaScript.hs
532 lines 14 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript
3 ( Output(..)
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
20import qualified AST.Canonical as Can
21import qualified AST.Optimized as Opt
22import qualified AST.Module.Name as ModuleName
23import qualified Data.Index as Index
24import qualified Elm.Interface as I
25import qualified Elm.Name as N
26import qualified Generate.JavaScript.Builder as JS
27import qualified Generate.JavaScript.Expression as Expr
28import qualified Generate.JavaScript.Name as Name
29import qualified Generate.JavaScript.Mode as Mode
30import qualified Reporting.Doc as D
31import qualified Reporting.Render.Type as RT
32import qualified Reporting.Render.Type.Localizer as L
36-- GENERATE MAINS
39data Output
40 = None
41 | Some N.Name [N.Name] B.Builder
44generate :: Mode.Mode -> Opt.Graph -> [ModuleName.Canonical] -> Output
45generate mode (Opt.Graph mains graph _fields) roots =
46 let
47 rootSet = Set.fromList roots
48 rootMap = Map.restrictKeys mains rootSet
49 in
50 case map ModuleName._module (Map.keys rootMap) of
51 [] ->
52 None
54 name:names ->
55 let
56 state = Map.foldrWithKey (addMain mode graph) emptyState rootMap
57 builder = stateToBuilder state <> toMainExports mode rootMap
58 in
59 Some name names builder
62addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
63addMain mode graph home _ state =
64 addGlobal mode graph state (Opt.Global home "main")
68-- GENERATE FOR REPL
71generateForRepl :: Bool -> L.Localizer -> Opt.Graph -> I.Interface -> ModuleName.Canonical -> N.Name -> B.Builder
72generateForRepl ansi localizer (Opt.Graph _ graph _) iface home name =
73 let
74 mode = Mode.dev Mode.Client
75 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
76 evalState = addGlobal mode graph debugState (Opt.Global home name)
77 in
78 stateToBuilder evalState
79 <>
80 print ansi localizer home name (I._types iface ! name)
83print :: Bool -> L.Localizer -> ModuleName.Canonical -> N.Name -> Can.Annotation -> B.Builder
84print ansi localizer home name (Can.Forall _ tipe) =
85 let
86 value = Name.toBuilder (Name.fromGlobal home name)
87 toString = Name.toBuilder (Name.fromKernel N.debug "toAnsiString")
88 tipeDoc = RT.canToDoc localizer RT.None tipe
89 bool = if ansi then "true" else "false"
90 in
91 "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
92 \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
93 \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
94 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
95 \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
96 \} else {\n\
97 \ _print(' : ' + _type);\n\
98 \}\n"
102-- GRAPH TRAVERSAL STATE
105data State =
106 State
107 { _revBuilders :: [B.Builder]
108 , _seenGlobals :: Set.Set Opt.Global
109 }
112emptyState :: State
113emptyState =
114 State [] Set.empty
117stateToBuilder :: State -> B.Builder
118stateToBuilder (State revBuilders _) =
119 List.foldl1' (\builder b -> b <> builder) revBuilders
123-- ADD DEPENDENCIES
126type Graph = Map.Map Opt.Global Opt.Node
129addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
130addGlobal mode graph state@(State builders seen) global =
131 if Set.member global seen then
132 state
133 else
134 addGlobalHelp mode graph global $
135 State builders (Set.insert global seen)
138addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
139addGlobalHelp mode graph global state =
140 let
141 addDeps deps someState =
142 Set.foldl' (addGlobal mode graph) someState deps
143 in
144 case graph ! global of
145 Opt.Define expr deps ->
146 addStmt (addDeps deps state) (
147 var global (Expr.generate mode expr)
148 )
150 Opt.DefineTailFunc argNames body deps ->
151 addStmt (addDeps deps state) (
152 let (Opt.Global _ name) = global in
153 var global (Expr.generateTailDef mode name argNames body)
154 )
156 Opt.Ctor index arity ->
157 addStmt state (
158 var global (Expr.generateCtor mode global index arity)
159 )
161 Opt.Link linkedGlobal ->
162 addGlobal mode graph state linkedGlobal
164 Opt.Cycle cycle deps ->
165 addStmt (addDeps deps state) (
166 generateCycle mode global cycle
167 )
169 Opt.Manager effectsType ->
170 generateManager mode graph global effectsType state
172 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
173 if isDebugger global && not (Mode.isDebug mode) then
174 state
175 else
176 case maybeServer of
177 Just (Opt.KContent serverChunks serverDeps) | Mode.isServer mode ->
178 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
180 _ ->
181 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
183 Opt.Enum index ->
184 addStmt state (
185 generateEnum mode global index
186 )
188 Opt.Box ->
189 addStmt state (
190 generateBox mode global
191 )
193 Opt.PortIncoming decoder deps ->
194 addStmt (addDeps deps state) (
195 generatePort mode global "incomingPort" decoder
196 )
198 Opt.PortOutgoing encoder deps ->
199 addStmt (addDeps deps state) (
200 generatePort mode global "outgoingPort" encoder
201 )
204addStmt :: State -> JS.Stmt -> State
205addStmt state stmt =
206 addBuilder state (JS.stmtToBuilder stmt)
209addBuilder :: State -> B.Builder -> State
210addBuilder (State revBuilders seen) builder =
211 State (builder:revBuilders) seen
214var :: Opt.Global -> Expr.Code -> JS.Stmt
215var (Opt.Global home name) code =
216 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
219isDebugger :: Opt.Global -> Bool
220isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
221 home == N.debugger
225-- GENERATE CYCLES
228generateCycle :: Mode.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
229generateCycle mode (Opt.Global home _) cycle =
230 let
231 safeDefs = map (generateSafeCycle mode home) cycle
232 realDefs = map (generateRealCycle home) cycle
233 block = JS.Block (safeDefs ++ realDefs)
234 in
235 case mode of
236 Mode.Prod _ _ ->
237 block
239 Mode.Dev _ _ ->
240 JS.Try block Name.dollar $ JS.Throw $ JS.String $
241 "The following top-level definitions are causing infinite recursion:\\n"
242 <> drawCycle (map fst cycle)
243 <> "\\n\\nThese errors are very tricky, so read "
244 <> B.stringUtf8 (D.makeLink "halting-problem")
245 <> " to learn how to fix it!"
248generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
249generateSafeCycle mode home (name, expr) =
250 JS.FunctionStmt (Name.fromCycle home name) [] $
251 Expr.codeToStmtList (Expr.generate mode expr)
254generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
255generateRealCycle home (name, _) =
256 let
257 safeName = Name.fromCycle home name
258 realName = Name.fromGlobal home name
259 in
260 JS.Block
261 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
262 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
263 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
264 ]
267drawCycle :: [N.Name] -> B.Builder
268drawCycle names =
269 let
270 topLine = "\\n ┌─────┐"
271 nameLine name = "\\n │ " <> N.toBuilder name
272 midLine = "\\n │ ↓"
273 bottomLine = "\\n └─────┘"
274 in
275 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
280-- GENERATE KERNEL
283generateKernel :: Mode.Mode -> [Opt.KChunk] -> B.Builder
284generateKernel mode chunks =
285 List.foldl' (addChunk mode) mempty chunks
288addChunk :: Mode.Mode -> B.Builder -> Opt.KChunk -> B.Builder
289addChunk mode builder chunk =
290 case chunk of
291 Opt.JS javascript ->
292 B.byteString javascript <> builder
294 Opt.ElmVar home name ->
295 Name.toBuilder (Name.fromGlobal home name) <> builder
297 Opt.JsVar home name ->
298 Name.toBuilder (Name.fromKernel home name) <> builder
300 Opt.ElmField name ->
301 Name.toBuilder (Expr.generateField mode name) <> builder
303 Opt.JsField int ->
304 Name.toBuilder (Name.fromInt int) <> builder
306 Opt.JsEnum int ->
307 B.intDec int <> builder
309 Opt.Debug ->
310 case mode of
311 Mode.Dev _ _ ->
312 builder
314 Mode.Prod _ _ ->
315 "_UNUSED" <> builder
317 Opt.Prod ->
318 case mode of
319 Mode.Dev _ _ ->
320 "_UNUSED" <> builder
322 Mode.Prod _ _ ->
323 builder
327-- GENERATE ENUM
330generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
331generateEnum mode global@(Opt.Global home name) index =
332 let
333 definition =
334 case mode of
335 Mode.Dev _ _ ->
336 Expr.codeToExpr (Expr.generateCtor mode global index 0)
338 Mode.Prod _ _ ->
339 JS.Int (Index.toMachine index)
340 in
341 JS.Var [ (Name.fromGlobal home name, Just definition) ]
345-- GENERATE BOX
348generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
349generateBox mode global@(Opt.Global home name) =
350 let
351 definition =
352 case mode of
353 Mode.Dev _ _ ->
354 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
356 Mode.Prod _ _ ->
357 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
358 in
359 JS.Var [ (Name.fromGlobal home name, Just definition) ]
363-- GENERATE PORTS
366generatePort :: Mode.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
367generatePort mode (Opt.Global home name) makePort converter =
368 let
369 definition =
370 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
371 [ JS.String (N.toBuilder name)
372 , Expr.codeToExpr (Expr.generate mode converter)
373 ]
374 in
375 JS.Var [ (Name.fromGlobal home name, Just definition) ]
379-- GENERATE MANAGER
382generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
383generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
384 let
385 managerLVar =
386 JS.LBracket
387 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
388 (JS.String (N.toBuilder moduleName))
390 (deps, args, stmts) =
391 generateManagerHelp home effectsType
393 createManager =
394 JS.ExprStmt $ JS.Assign managerLVar $
395 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
396 in
397 addStmt (List.foldl' (addGlobal mode graph) state deps) $
398 JS.Block (createManager : stmts)
401generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
402generateLeaf home@(ModuleName.Canonical _ moduleName) name =
403 let
404 definition =
405 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
406 in
407 JS.Var [ (Name.fromGlobal home name, Just definition) ]
410{-# NOINLINE leaf #-}
411leaf :: JS.Expr
412leaf =
413 JS.Ref (Name.fromKernel N.platform "leaf")
416generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
417generateManagerHelp home effectsType =
418 let
419 dep name = Opt.Global home name
420 ref name = JS.Ref (Name.fromGlobal home name)
421 in
422 case effectsType of
423 Opt.Cmd ->
424 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
425 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
426 , [ generateLeaf home "command" ]
427 )
429 Opt.Sub ->
430 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
431 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
432 , [ generateLeaf home "subscription" ]
433 )
435 Opt.Fx ->
436 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
437 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
438 , [ generateLeaf home "command"
439 , generateLeaf home "subscription"
440 ]
441 )
445-- MAIN EXPORTS
448toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
449toMainExports mode mains =
450 let
451 export = Name.fromKernel N.platform "export"
452 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
453 in
454 Name.toBuilder export <> "(" <> exports <> ");"
457generateExports :: Mode.Mode -> Trie -> B.Builder
458generateExports mode (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 subTrie
468 <> List.foldl' (addSubTrie mode) "}" otherSubTries
469 in
470 case maybeMain of
471 Nothing ->
472 object
474 Just (home, main) ->
475 let initialize = Expr.generateMain mode home main in
476 JS.exprToBuilder initialize <> "(" <> object <> ")"
479addSubTrie :: Mode.Mode -> B.Builder -> (Text.Text, Trie) -> B.Builder
480addSubTrie mode end (name, trie) =
481 ",'" <> Text.encodeUtf8Builder name <> "':" <> generateExports mode trie <> 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"