git.iko.soy/elk
on d2dacad help sign in
elk/compiler/src/Generate/JavaScript.hs
520 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 in
245 JS.Block (safeDefs ++ realDefs)
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 ]
268-- GENERATE KERNEL
271generateKernel :: Mode.Mode -> [Opt.KChunk] -> B.Builder
272generateKernel mode chunks =
273 List.foldl' (addChunk mode) mempty chunks
276addChunk :: Mode.Mode -> B.Builder -> Opt.KChunk -> B.Builder
277addChunk mode builder chunk =
278 case chunk of
279 Opt.JS javascript ->
280 B.byteString javascript <> builder
282 Opt.ElmVar home name ->
283 Name.toBuilder (Name.fromGlobal home name) <> builder
285 Opt.JsVar home name ->
286 Name.toBuilder (Name.fromKernel home name) <> builder
288 Opt.ElmField name ->
289 Name.toBuilder (Expr.generateField mode name) <> builder
291 Opt.JsField int ->
292 Name.toBuilder (Name.fromInt int) <> builder
294 Opt.JsEnum int ->
295 B.intDec int <> builder
297 Opt.Debug ->
298 case mode of
299 Mode.Dev _ _ ->
300 builder
302 Mode.Prod _ _ ->
303 "_UNUSED" <> builder
305 Opt.Prod ->
306 case mode of
307 Mode.Dev _ _ ->
308 "_UNUSED" <> builder
310 Mode.Prod _ _ ->
311 builder
315-- GENERATE ENUM
318generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
319generateEnum mode global@(Opt.Global home name) index =
320 let
321 definition =
322 case mode of
323 Mode.Dev _ _ ->
324 Expr.codeToExpr (Expr.generateCtor mode global index 0)
326 Mode.Prod _ _ ->
327 JS.Int (Index.toMachine index)
328 in
329 JS.Var [ (Name.fromGlobal home name, Just definition) ]
333-- GENERATE BOX
336generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
337generateBox mode global@(Opt.Global home name) =
338 let
339 definition =
340 case mode of
341 Mode.Dev _ _ ->
342 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
344 Mode.Prod _ _ ->
345 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
346 in
347 JS.Var [ (Name.fromGlobal home name, Just definition) ]
351-- GENERATE PORTS
354generatePort :: Mode.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
355generatePort mode (Opt.Global home name) makePort converter =
356 let
357 definition =
358 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
359 [ JS.String (N.toBuilder name)
360 , Expr.codeToExpr (Expr.generate mode converter)
361 ]
362 in
363 JS.Var [ (Name.fromGlobal home name, Just definition) ]
367-- GENERATE MANAGER
370generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
371generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
372 let
373 managerLVar =
374 JS.LBracket
375 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
376 (JS.String (N.toBuilder moduleName))
378 (deps, args, stmts) =
379 generateManagerHelp home effectsType
381 createManager =
382 JS.ExprStmt $ JS.Assign managerLVar $
383 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
384 in
385 addStmt (List.foldl' (addGlobal mode graph) state deps) $
386 JS.Block (createManager : stmts)
389generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
390generateLeaf home@(ModuleName.Canonical _ moduleName) name =
391 let
392 definition =
393 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
394 in
395 JS.Var [ (Name.fromGlobal home name, Just definition) ]
398{-# NOINLINE leaf #-}
399leaf :: JS.Expr
400leaf =
401 JS.Ref (Name.fromKernel N.platform "leaf")
404generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
405generateManagerHelp home effectsType =
406 let
407 dep name = Opt.Global home name
408 ref name = JS.Ref (Name.fromGlobal home name)
409 in
410 case effectsType of
411 Opt.Cmd ->
412 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
413 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
414 , [ generateLeaf home "command" ]
415 )
417 Opt.Sub ->
418 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
419 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
420 , [ generateLeaf home "subscription" ]
421 )
423 Opt.Fx ->
424 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
425 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
426 , [ generateLeaf home "command"
427 , generateLeaf home "subscription"
428 ]
429 )
433-- MAIN EXPORTS
436toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
437toMainExports mode mains =
438 let
439 export = Name.fromKernel N.platform "export"
440 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
441 in
442 Name.toBuilder export <> "(" <> exports <> ");"
445generateExports :: Mode.Mode -> Trie -> B.Builder
446generateExports mode (Trie maybeMain subs) =
447 let
448 object =
449 case Map.toList subs of
450 [] ->
451 "{}"
453 (name, subTrie) : otherSubTries ->
454 "{'" <> Text.encodeUtf8Builder name <> "':"
455 <> generateExports mode subTrie
456 <> List.foldl' (addSubTrie mode) "}" otherSubTries
457 in
458 case maybeMain of
459 Nothing ->
460 object
462 Just (home, main) ->
463 let initialize = Expr.generateMain mode home main in
464 JS.exprToBuilder initialize <> "(" <> object <> ")"
467addSubTrie :: Mode.Mode -> B.Builder -> (Text.Text, Trie) -> B.Builder
468addSubTrie mode end (name, trie) =
469 ",'" <> Text.encodeUtf8Builder name <> "':" <> generateExports mode trie <> end
473-- BUILD TRIES
476data Trie =
477 Trie
478 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
479 , _subs :: Map.Map Text.Text Trie
480 }
483emptyTrie :: Trie
484emptyTrie =
485 Trie Nothing Map.empty
488addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
489addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
490 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
493segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
494segmentsToTrie home segments main =
495 case segments of
496 [] ->
497 Trie (Just (home, main)) Map.empty
499 segment : otherSegments ->
500 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
503merge :: Trie -> Trie -> Trie
504merge (Trie main1 subs1) (Trie main2 subs2) =
505 Trie
506 (checkedMerge main1 main2)
507 (Map.unionWith merge subs1 subs2)
510checkedMerge :: Maybe a -> Maybe a -> Maybe a
511checkedMerge a b =
512 case (a, b) of
513 (Nothing, main) ->
514 main
516 (main, Nothing) ->
517 main
519 (Just _, Just _) ->
520 error "cannot have two modules with the same name"