git.iko.soy/elk
on f4707e6 help sign in
elk/compiler/src/Generate/JavaScript.hs
581 lines 16 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.Name as Name
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 Data.Index as Index
24import qualified Elm.Interface as I
25import qualified Elm.ModuleName as ModuleName
26import qualified Generate.JavaScript.Builder as JS
27import qualified Generate.JavaScript.Expression as Expr
28import qualified Generate.JavaScript.Name as JsName
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 Name.Name [Name.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 = perfNote mode <> 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")
67perfNote :: Mode.Mode -> B.Builder
68perfNote mode =
69 case mode of
70 Mode.Prod _ _ ->
71 ""
73 Mode.Dev _ Nothing ->
74 "console.warn('Compiled in DEV mode. Follow the advice at "
75 <> B.stringUtf8 (D.makeNakedLink "optimize")
76 <> " for better performance and smaller assets.');"
78 Mode.Dev _ (Just _) ->
79 "console.warn('Compiled in DEBUG mode. Follow the advice at "
80 <> B.stringUtf8 (D.makeNakedLink "optimize")
81 <> " for better performance and smaller assets.');"
85-- GENERATE FOR REPL
88generateForRepl :: Bool -> L.Localizer -> Opt.Graph -> I.Interface -> ModuleName.Canonical -> Name.Name -> B.Builder
89generateForRepl ansi localizer (Opt.Graph _ graph _) iface home name =
90 let
91 mode = Mode.dev Mode.Client
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
96 <>
97 print ansi localizer home name (I._types iface ! name)
100print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
101print ansi localizer home name (Can.Forall _ tipe) =
102 let
103 value = JsName.toBuilder (JsName.fromGlobal home name)
104 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
105 tipeDoc = RT.canToDoc localizer RT.None tipe
106 bool = if ansi then "true" else "false"
107 in
108 "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
109 \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
110 \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
111 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
112 \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
113 \} else {\n\
114 \ _print(' : ' + _type);\n\
115 \}\n"
119-- GRAPH TRAVERSAL STATE
122data State =
123 State
124 { _revKernels :: [B.Builder]
125 , _revBuilders :: [B.Builder]
126 , _seenGlobals :: Set.Set Opt.Global
127 }
130emptyState :: State
131emptyState =
132 State mempty [] Set.empty
135stateToBuilder :: State -> B.Builder
136stateToBuilder (State revKernels revBuilders _) =
137 prependBuilders revKernels (prependBuilders revBuilders mempty)
140prependBuilders :: [B.Builder] -> B.Builder -> B.Builder
141prependBuilders revBuilders monolith =
142 List.foldl' (\m b -> b <> m) monolith revBuilders
146-- ADD DEPENDENCIES
149type Graph = Map.Map Opt.Global Opt.Node
152addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
153addGlobal mode graph state@(State revKernels builders seen) global =
154 if Set.member global seen then
155 state
156 else
157 addGlobalHelp mode graph global $
158 State revKernels builders (Set.insert global seen)
161addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State
162addGlobalHelp mode graph global state =
163 let
164 addDeps deps someState =
165 Set.foldl' (addGlobal mode graph) someState deps
166 in
167 case graph ! global of
168 Opt.Define expr deps ->
169 addStmt (addDeps deps state) (
170 var global (Expr.generate mode expr)
171 )
173 Opt.DefineTailFunc argNames body deps ->
174 addStmt (addDeps deps state) (
175 let (Opt.Global _ name) = global in
176 var global (Expr.generateTailDef mode name argNames body)
177 )
179 Opt.Ctor index arity ->
180 addStmt state (
181 var global (Expr.generateCtor mode global index arity)
182 )
184 Opt.Link linkedGlobal ->
185 addGlobal mode graph state linkedGlobal
187 Opt.Cycle names values functions deps ->
188 addStmt (addDeps deps state) (
189 generateCycle mode global names values functions
190 )
192 Opt.Manager effectsType ->
193 generateManager mode graph global effectsType state
195 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
196 if isDebugger global && not (Mode.isDebug mode) then
197 state
198 else
199 case maybeServer of
200 Just (Opt.KContent serverChunks serverDeps) | Mode.isServer mode ->
201 addKernel (addDeps serverDeps state) (generateKernel mode serverChunks)
203 _ ->
204 addKernel (addDeps clientDeps state) (generateKernel mode clientChunks)
206 Opt.Enum index ->
207 addStmt state (
208 generateEnum mode global index
209 )
211 Opt.Box ->
212 addStmt (addGlobal mode graph state identity) (
213 generateBox mode global
214 )
216 Opt.PortIncoming decoder deps ->
217 addStmt (addDeps deps state) (
218 generatePort mode global "incomingPort" decoder
219 )
221 Opt.PortOutgoing encoder deps ->
222 addStmt (addDeps deps state) (
223 generatePort mode global "outgoingPort" encoder
224 )
227addStmt :: State -> JS.Stmt -> State
228addStmt state stmt =
229 addBuilder state (JS.stmtToBuilder stmt)
232addBuilder :: State -> B.Builder -> State
233addBuilder (State revKernels revBuilders seen) builder =
234 State revKernels (builder:revBuilders) seen
237addKernel :: State -> B.Builder -> State
238addKernel (State revKernels revBuilders seen) kernel =
239 State (kernel:revKernels) revBuilders seen
242var :: Opt.Global -> Expr.Code -> JS.Stmt
243var (Opt.Global home name) code =
244 JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]
247isDebugger :: Opt.Global -> Bool
248isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =
249 home == Name.debugger
253-- GENERATE CYCLES
256generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt
257generateCycle mode (Opt.Global home _) names values functions =
258 JS.Block
259 [ JS.Block $ map (generateCycleFunc mode home) functions
260 , JS.Block $ map (generateSafeCycle mode home) values
261 , case map (generateRealCycle home) values of
262 [] ->
263 JS.EmptyStmt
265 realBlock@(_:_) ->
266 case mode of
267 Mode.Prod _ _ ->
268 JS.Block realBlock
270 Mode.Dev _ _ ->
271 JS.Try (JS.Block realBlock) JsName.dollar $ JS.Throw $ JS.String $
272 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
273 <> drawCycle names
274 <> "\\n\\nThese errors are very tricky, so read "
275 <> B.stringUtf8 (D.makeNakedLink "halting-problem")
276 <> " to learn how to fix it!"
277 ]
280generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
281generateCycleFunc mode home def =
282 case def of
283 Opt.Def name expr ->
284 JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
286 Opt.TailDef name args expr ->
287 JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
290generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
291generateSafeCycle mode home (name, expr) =
292 JS.FunctionStmt (JsName.fromCycle home name) [] $
293 Expr.codeToStmtList (Expr.generate mode expr)
296generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt
297generateRealCycle home (name, _) =
298 let
299 safeName = JsName.fromCycle home name
300 realName = JsName.fromGlobal home name
301 in
302 JS.Block
303 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
304 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
305 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
306 ]
309drawCycle :: [Name.Name] -> B.Builder
310drawCycle names =
311 let
312 topLine = "\\n ┌─────┐"
313 nameLine name = "\\n │ " <> Name.toBuilder name
314 midLine = "\\n │ ↓"
315 bottomLine = "\\n └─────┘"
316 in
317 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
321-- GENERATE KERNEL
324generateKernel :: Mode.Mode -> [Opt.KChunk] -> B.Builder
325generateKernel mode chunks =
326 List.foldl' (addChunk mode) mempty chunks
329addChunk :: Mode.Mode -> B.Builder -> Opt.KChunk -> B.Builder
330addChunk mode builder chunk =
331 case chunk of
332 Opt.JS javascript ->
333 B.byteString javascript <> builder
335 Opt.ElmVar home name ->
336 JsName.toBuilder (JsName.fromGlobal home name) <> builder
338 Opt.JsVar home name ->
339 JsName.toBuilder (JsName.fromKernel home name) <> builder
341 Opt.ElmField name ->
342 JsName.toBuilder (Expr.generateField mode name) <> builder
344 Opt.JsField int ->
345 JsName.toBuilder (JsName.fromInt int) <> builder
347 Opt.JsEnum int ->
348 B.intDec int <> builder
350 Opt.Debug ->
351 case mode of
352 Mode.Dev _ _ ->
353 builder
355 Mode.Prod _ _ ->
356 "_UNUSED" <> builder
358 Opt.Prod ->
359 case mode of
360 Mode.Dev _ _ ->
361 "_UNUSED" <> builder
363 Mode.Prod _ _ ->
364 builder
368-- GENERATE ENUM
371generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
372generateEnum mode global@(Opt.Global home name) index =
373 let
374 definition =
375 case mode of
376 Mode.Dev _ _ ->
377 Expr.codeToExpr (Expr.generateCtor mode global index 0)
379 Mode.Prod _ _ ->
380 JS.Int (Index.toMachine index)
381 in
382 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
386-- GENERATE BOX
389generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
390generateBox mode global@(Opt.Global home name) =
391 let
392 definition =
393 case mode of
394 Mode.Dev _ _ ->
395 Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
397 Mode.Prod _ _ ->
398 JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
399 in
400 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
403{-# NOINLINE identity #-}
404identity :: Opt.Global
405identity =
406 Opt.Global ModuleName.basics Name.identity
410-- GENERATE PORTS
413generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
414generatePort mode (Opt.Global home name) makePort converter =
415 let
416 definition =
417 JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
418 [ JS.String (Name.toBuilder name)
419 , Expr.codeToExpr (Expr.generate mode converter)
420 ]
421 in
422 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
426-- GENERATE MANAGER
429generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
430generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
431 let
432 managerLVar =
433 JS.LBracket
434 (JS.Ref (JsName.fromKernel Name.platform "effectManagers"))
435 (JS.String (Name.toBuilder moduleName))
437 (deps, args, stmts) =
438 generateManagerHelp home effectsType
440 createManager =
441 JS.ExprStmt $ JS.Assign managerLVar $
442 JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args
443 in
444 addStmt (List.foldl' (addGlobal mode graph) state deps) $
445 JS.Block (createManager : stmts)
448generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
449generateLeaf home@(ModuleName.Canonical _ moduleName) name =
450 let
451 definition =
452 JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
453 in
454 JS.Var [ (JsName.fromGlobal home name, Just definition) ]
457{-# NOINLINE leaf #-}
458leaf :: JS.Expr
459leaf =
460 JS.Ref (JsName.fromKernel Name.platform "leaf")
463generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
464generateManagerHelp home effectsType =
465 let
466 dep name = Opt.Global home name
467 ref name = JS.Ref (JsName.fromGlobal home name)
468 in
469 case effectsType of
470 Opt.Cmd ->
471 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
472 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
473 , [ generateLeaf home "command" ]
474 )
476 Opt.Sub ->
477 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
478 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
479 , [ generateLeaf home "subscription" ]
480 )
482 Opt.Fx ->
483 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
484 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
485 , [ generateLeaf home "command"
486 , generateLeaf home "subscription"
487 ]
488 )
492-- MAIN EXPORTS
495toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
496toMainExports mode mains =
497 let
498 export = JsName.fromKernel Name.platform "export"
499 exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)
500 in
501 JsName.toBuilder export <> "(" <> exports <> ");"
504generateExports :: Mode.Mode -> Trie -> B.Builder
505generateExports mode (Trie maybeMain subs) =
506 let
507 starter end =
508 case maybeMain of
509 Nothing ->
510 "{"
512 Just (home, main) ->
513 "{'init':"
514 <> JS.exprToBuilder (Expr.generateMain mode home main)
515 <> end
516 in
517 case Map.toList subs of
518 [] ->
519 starter "" <> "}"
521 (name, subTrie) : otherSubTries ->
522 starter "," <>
523 "'" <> Text.encodeUtf8Builder name <> "':"
524 <> generateExports mode subTrie
525 <> List.foldl' (addSubTrie mode) "}" otherSubTries
528addSubTrie :: Mode.Mode -> B.Builder -> (Text.Text, Trie) -> B.Builder
529addSubTrie mode end (name, trie) =
530 ",'" <> Text.encodeUtf8Builder name <> "':" <> generateExports mode trie <> end
534-- BUILD TRIES
537data Trie =
538 Trie
539 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
540 , _subs :: Map.Map Text.Text Trie
541 }
544emptyTrie :: Trie
545emptyTrie =
546 Trie Nothing Map.empty
549addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
550addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
551 merge trie $ segmentsToTrie home (Text.splitOn "." (Name.toText moduleName)) main
554segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
555segmentsToTrie home segments main =
556 case segments of
557 [] ->
558 Trie (Just (home, main)) Map.empty
560 segment : otherSegments ->
561 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
564merge :: Trie -> Trie -> Trie
565merge (Trie main1 subs1) (Trie main2 subs2) =
566 Trie
567 (checkedMerge main1 main2)
568 (Map.unionWith merge subs1 subs2)
571checkedMerge :: Maybe a -> Maybe a -> Maybe a
572checkedMerge a b =
573 case (a, b) of
574 (Nothing, main) ->
575 main
577 (main, Nothing) ->
578 main
580 (Just _, Just _) ->
581 error "cannot have two modules with the same name"