git.iko.soy/elk
on 665d3d9 help sign in
elk/compiler/src/Generate/JavaScript.hs
543 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 { _kernel :: B.Builder
108 , _revBuilders :: [B.Builder]
109 , _seenGlobals :: Set.Set Opt.Global
110 }
113emptyState :: State
114emptyState =
115 State mempty [] Set.empty
118stateToBuilder :: State -> B.Builder
119stateToBuilder (State kernel revBuilders _) =
120 case revBuilders of
121 [] ->
122 kernel
124 b:bs ->
125 kernel <> List.foldl' (\code decl -> decl <> code) b bs
129-- ADD DEPENDENCIES
132type Graph = Map.Map Opt.Global Opt.Node
135addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
136addGlobal mode graph state@(State kernel builders seen) global =
137 if Set.member global seen then
138 state
139 else
140 addGlobalHelp mode graph global $
141 State kernel builders (Set.insert global seen)
144addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
145addGlobalHelp mode graph global state =
146 let
147 addDeps deps someState =
148 Set.foldl' (addGlobal mode graph) someState deps
149 in
150 case graph ! global of
151 Opt.Define expr deps ->
152 addStmt (addDeps deps state) (
153 var global (Expr.generate mode expr)
154 )
156 Opt.DefineTailFunc argNames body deps ->
157 addStmt (addDeps deps state) (
158 let (Opt.Global _ name) = global in
159 var global (Expr.generateTailDef mode name argNames body)
160 )
162 Opt.Ctor index arity ->
163 addStmt state (
164 var global (Expr.generateCtor mode global index arity)
165 )
167 Opt.Link linkedGlobal ->
168 addGlobal mode graph state linkedGlobal
170 Opt.Cycle cycle deps ->
171 addStmt (addDeps deps state) (
172 generateCycle mode global cycle
173 )
175 Opt.Manager effectsType ->
176 generateManager mode graph global effectsType state
178 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
179 if isDebugger global && not (Mode.isDebug mode) then
180 state
181 else
182 case maybeServer of
183 Just (Opt.KContent serverChunks serverDeps) | Mode.isServer mode ->
184 addKernel (addDeps serverDeps state) (generateKernel mode serverChunks)
186 _ ->
187 addKernel (addDeps clientDeps state) (generateKernel mode clientChunks)
189 Opt.Enum index ->
190 addStmt state (
191 generateEnum mode global index
192 )
194 Opt.Box ->
195 addStmt state (
196 generateBox mode global
197 )
199 Opt.PortIncoming decoder deps ->
200 addStmt (addDeps deps state) (
201 generatePort mode global "incomingPort" decoder
202 )
204 Opt.PortOutgoing encoder deps ->
205 addStmt (addDeps deps state) (
206 generatePort mode global "outgoingPort" encoder
207 )
210addStmt :: State -> JS.Stmt -> State
211addStmt state stmt =
212 addBuilder state (JS.stmtToBuilder stmt)
215addBuilder :: State -> B.Builder -> State
216addBuilder (State kernel revBuilders seen) builder =
217 State kernel (builder:revBuilders) seen
220addKernel :: State -> B.Builder -> State
221addKernel (State kernel revBuilders seen) moreKernel =
222 State (moreKernel <> kernel) revBuilders seen
225var :: Opt.Global -> Expr.Code -> JS.Stmt
226var (Opt.Global home name) code =
227 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
230isDebugger :: Opt.Global -> Bool
231isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
232 home == N.debugger
236-- GENERATE CYCLES
239generateCycle :: Mode.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
240generateCycle mode (Opt.Global home _) cycle =
241 let
242 safeDefs = map (generateSafeCycle mode home) cycle
243 realDefs = map (generateRealCycle home) cycle
244 block = JS.Block (safeDefs ++ realDefs)
245 in
246 case mode of
247 Mode.Prod _ _ ->
248 block
250 Mode.Dev _ _ ->
251 JS.Try block Name.dollar $ JS.Throw $ JS.String $
252 "The following top-level definitions are causing infinite recursion:\\n"
253 <> drawCycle (map fst cycle)
254 <> "\\n\\nThese errors are very tricky, so read "
255 <> B.stringUtf8 (D.makeLink "halting-problem")
256 <> " to learn how to fix it!"
259generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
260generateSafeCycle mode home (name, expr) =
261 JS.FunctionStmt (Name.fromCycle home name) [] $
262 Expr.codeToStmtList (Expr.generate mode expr)
265generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
266generateRealCycle home (name, _) =
267 let
268 safeName = Name.fromCycle home name
269 realName = Name.fromGlobal home name
270 in
271 JS.Block
272 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
273 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
274 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
275 ]
278drawCycle :: [N.Name] -> B.Builder
279drawCycle names =
280 let
281 topLine = "\\n ┌─────┐"
282 nameLine name = "\\n │ " <> N.toBuilder name
283 midLine = "\\n │ ↓"
284 bottomLine = "\\n └─────┘"
285 in
286 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
291-- GENERATE KERNEL
294generateKernel :: Mode.Mode -> [Opt.KChunk] -> B.Builder
295generateKernel mode chunks =
296 List.foldl' (addChunk mode) mempty chunks
299addChunk :: Mode.Mode -> B.Builder -> Opt.KChunk -> B.Builder
300addChunk mode builder chunk =
301 case chunk of
302 Opt.JS javascript ->
303 B.byteString javascript <> builder
305 Opt.ElmVar home name ->
306 Name.toBuilder (Name.fromGlobal home name) <> builder
308 Opt.JsVar home name ->
309 Name.toBuilder (Name.fromKernel home name) <> builder
311 Opt.ElmField name ->
312 Name.toBuilder (Expr.generateField mode name) <> builder
314 Opt.JsField int ->
315 Name.toBuilder (Name.fromInt int) <> builder
317 Opt.JsEnum int ->
318 B.intDec int <> builder
320 Opt.Debug ->
321 case mode of
322 Mode.Dev _ _ ->
323 builder
325 Mode.Prod _ _ ->
326 "_UNUSED" <> builder
328 Opt.Prod ->
329 case mode of
330 Mode.Dev _ _ ->
331 "_UNUSED" <> builder
333 Mode.Prod _ _ ->
334 builder
338-- GENERATE ENUM
341generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
342generateEnum mode global@(Opt.Global home name) index =
343 let
344 definition =
345 case mode of
346 Mode.Dev _ _ ->
347 Expr.codeToExpr (Expr.generateCtor mode global index 0)
349 Mode.Prod _ _ ->
350 JS.Int (Index.toMachine index)
351 in
352 JS.Var [ (Name.fromGlobal home name, Just definition) ]
356-- GENERATE BOX
359generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
360generateBox mode global@(Opt.Global home name) =
361 let
362 definition =
363 case mode of
364 Mode.Dev _ _ ->
365 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
367 Mode.Prod _ _ ->
368 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
369 in
370 JS.Var [ (Name.fromGlobal home name, Just definition) ]
374-- GENERATE PORTS
377generatePort :: Mode.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
378generatePort mode (Opt.Global home name) makePort converter =
379 let
380 definition =
381 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
382 [ JS.String (N.toBuilder name)
383 , Expr.codeToExpr (Expr.generate mode converter)
384 ]
385 in
386 JS.Var [ (Name.fromGlobal home name, Just definition) ]
390-- GENERATE MANAGER
393generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
394generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
395 let
396 managerLVar =
397 JS.LBracket
398 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
399 (JS.String (N.toBuilder moduleName))
401 (deps, args, stmts) =
402 generateManagerHelp home effectsType
404 createManager =
405 JS.ExprStmt $ JS.Assign managerLVar $
406 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
407 in
408 addStmt (List.foldl' (addGlobal mode graph) state deps) $
409 JS.Block (createManager : stmts)
412generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
413generateLeaf home@(ModuleName.Canonical _ moduleName) name =
414 let
415 definition =
416 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
417 in
418 JS.Var [ (Name.fromGlobal home name, Just definition) ]
421{-# NOINLINE leaf #-}
422leaf :: JS.Expr
423leaf =
424 JS.Ref (Name.fromKernel N.platform "leaf")
427generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
428generateManagerHelp home effectsType =
429 let
430 dep name = Opt.Global home name
431 ref name = JS.Ref (Name.fromGlobal home name)
432 in
433 case effectsType of
434 Opt.Cmd ->
435 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
436 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
437 , [ generateLeaf home "command" ]
438 )
440 Opt.Sub ->
441 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
442 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
443 , [ generateLeaf home "subscription" ]
444 )
446 Opt.Fx ->
447 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
448 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
449 , [ generateLeaf home "command"
450 , generateLeaf home "subscription"
451 ]
452 )
456-- MAIN EXPORTS
459toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
460toMainExports mode mains =
461 let
462 export = Name.fromKernel N.platform "export"
463 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
464 in
465 Name.toBuilder export <> "(" <> exports <> ");"
468generateExports :: Mode.Mode -> Trie -> B.Builder
469generateExports mode (Trie maybeMain subs) =
470 let
471 object =
472 case Map.toList subs of
473 [] ->
474 "{}"
476 (name, subTrie) : otherSubTries ->
477 "{'" <> Text.encodeUtf8Builder name <> "':"
478 <> generateExports mode subTrie
479 <> List.foldl' (addSubTrie mode) "}" otherSubTries
480 in
481 case maybeMain of
482 Nothing ->
483 object
485 Just (home, main) ->
486 let initialize = Expr.generateMain mode home main in
487 JS.exprToBuilder initialize <> "(" <> object <> ")"
490addSubTrie :: Mode.Mode -> B.Builder -> (Text.Text, Trie) -> B.Builder
491addSubTrie mode end (name, trie) =
492 ",'" <> Text.encodeUtf8Builder name <> "':" <> generateExports mode trie <> 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"