git.iko.soy/elk
on 266e49d help sign in
elk/src/Generate/JavaScript.hs
533 lines 14 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript
4 ( Mode(..)
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.Optimized as Opt
22import qualified AST.Module.Name as ModuleName
23import qualified Data.Index as Index
24import qualified Elm.Compiler.Type as Type
25import qualified Elm.Compiler.Type.Extract as Extract
26import qualified Elm.Interface as I
27import qualified Elm.Name as N
28import qualified Generate.JavaScript.Builder as JS
29import qualified Generate.JavaScript.Expression as Expr
30import qualified Generate.JavaScript.Name as Name
31import qualified Reporting.Helpers as H
35-- GENERATE MAINS
38data Mode = Debug | Prod
41generate :: Mode -> Name.Target -> I.Interfaces -> Opt.Graph -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] B.Builder
42generate mode target interfaces (Opt.Graph mains graph fields) roots =
43 let
44 rootSet = Set.fromList roots
45 rootMap = Map.restrictKeys mains rootSet
46 in
47 if Map.size rootMap == Set.size rootSet then
48 let
49 realMode = toRealMode mode target fields
50 state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap
51 in
52 Right $ stateToBuilder state <> toMainExports realMode interfaces rootMap
54 else
55 Left $ Set.toList $
56 Set.intersection rootSet (Map.keysSet mains)
59addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
60addMain mode graph home _ state =
61 addGlobal mode graph state (Opt.Global home "main")
64toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
65toRealMode mode target fields =
66 case mode of
67 Debug ->
68 Name.Debug target
70 Prod ->
71 Name.Prod target (Name.shortenFieldNames fields)
75-- GENERATE FOR REPL
78generateForRepl :: I.Interfaces -> Opt.Graph -> ModuleName.Canonical -> N.Name -> B.Builder
79generateForRepl interfaces (Opt.Graph _ graph _) home name =
80 let
81 mode = Name.Debug Name.Server
82 eval = addGlobal mode graph emptyState (Opt.Global home name)
83 in
84 stateToBuilder eval <> print interfaces home name
87print :: I.Interfaces -> ModuleName.Canonical -> N.Name -> B.Builder
88print interfaces home name =
89 let
90 value = Name.toBuilder (Name.fromGlobal home name)
91 toString = Name.toBuilder (Name.fromKernel N.debug "toString")
92 annotation = I._types (interfaces ! home) ! name
93 tipe = Type.toString Type.MultiLine $ Extract.fromAnnotation annotation
94 in
95 "var _value = " <> toString <> "(" <> value <> ");\n" <>
96 "var _type = '" <> B.stringUtf8 (show tipe) <> "';\n\
97 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
98 \ console.log(_value + '\\n : ' + _type.split('\\n').join('\\n '));\n\
99 \} else {\n\
100 \ console.log(_value + ' : ' + _type);\n\
101 \}\n"
105-- GRAPH TRAVERSAL STATE
108data State =
109 State
110 { _revBuilders :: [B.Builder]
111 , _seenGlobals :: Set.Set Opt.Global
112 }
115emptyState :: State
116emptyState =
117 State [] Set.empty
120stateToBuilder :: State -> B.Builder
121stateToBuilder (State revBuilders _) =
122 List.foldl1' (\builder b -> b <> builder) revBuilders
126-- ADD DEPENDENCIES
129type Graph = Map.Map Opt.Global Opt.Node
132addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
133addGlobal mode graph state@(State builders seen) global =
134 if Set.member global seen then
135 state
136 else
137 addGlobalHelp mode graph global $
138 State builders (Set.insert global seen)
141addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
142addGlobalHelp mode graph global state =
143 let
144 addDeps deps someState =
145 Set.foldl' (addGlobal mode graph) someState deps
146 in
147 case graph ! global of
148 Opt.Define expr deps ->
149 addStmt (addDeps deps state) (
150 var global (Expr.generate mode expr)
151 )
153 Opt.DefineTailFunc argNames body deps ->
154 addStmt (addDeps deps state) (
155 let (Opt.Global _ name) = global in
156 var global (Expr.generateTailDef mode name argNames body)
157 )
159 Opt.Ctor name index arity ->
160 addStmt state (
161 var global (Expr.generateCtor mode name index arity)
162 )
164 Opt.Link linkedGlobal ->
165 addGlobal mode graph state linkedGlobal
167 Opt.Cycle cycle deps ->
168 addStmt (addDeps deps state) (
169 generateCycle mode global cycle
170 )
172 Opt.Manager effectsType ->
173 generateManager mode graph global effectsType state
175 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
176 case maybeServer of
177 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
178 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
180 _ ->
181 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
183 Opt.Enum name index ->
184 addStmt state (
185 generateEnum mode global name index
186 )
188 Opt.Box name ->
189 addStmt state (
190 generateBox mode global name
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)) ]
220-- GENERATE CYCLES
223generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
224generateCycle mode (Opt.Global home _) cycle =
225 let
226 safeDefs = map (generateSafeCycle mode home) cycle
227 realDefs = map (generateRealCycle home) cycle
228 block = JS.Block (safeDefs ++ realDefs)
229 in
230 case mode of
231 Name.Prod _ _ ->
232 block
234 Name.Debug _ ->
235 JS.Try block Name.dollar $ JS.Throw $ JS.String $
236 "The following top-level definitions are causing infinite recursion:\\n"
237 <> drawCycle (map fst cycle)
238 <> "\\n\\nThese errors are very tricky, so read "
239 <> B.stringUtf8 (H.makeLink "halting-problem")
240 <> " to learn how to fix it!"
243generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
244generateSafeCycle mode home (name, expr) =
245 JS.FunctionStmt (Name.fromCycle home name) [] $
246 Expr.codeToStmtList (Expr.generate mode expr)
249generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
250generateRealCycle home (name, _) =
251 let
252 safeName = Name.fromCycle home name
253 realName = Name.fromGlobal home name
254 in
255 JS.Block
256 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
257 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
258 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
259 ]
262drawCycle :: [N.Name] -> B.Builder
263drawCycle names =
264 let
265 topLine = "\\n ┌─────┐"
266 nameLine name = "\\n │ " <> N.toBuilder name
267 midLine = "\\n │ ↓"
268 bottomLine = "\\n └─────┘"
269 in
270 mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])
275-- GENERATE KERNEL
278generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
279generateKernel mode chunks =
280 List.foldl' (addChunk mode) mempty chunks
283addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
284addChunk mode builder chunk =
285 case chunk of
286 Opt.JS javascript ->
287 B.byteString javascript <> builder
289 Opt.ElmVar home name ->
290 Name.toBuilder (Name.fromGlobal home name) <> builder
292 Opt.JsVar home name ->
293 Name.toBuilder (Name.fromKernel home name) <> builder
295 Opt.ElmField name ->
296 Name.toBuilder (Name.fromField mode name) <> builder
298 Opt.JsField int ->
299 Name.toBuilder (Name.fromInt int) <> builder
301 Opt.JsEnum int ->
302 B.intDec int <> builder
304 Opt.Debug ->
305 case mode of
306 Name.Debug _ ->
307 builder
309 Name.Prod _ _ ->
310 "_UNUSED" <> builder
312 Opt.Prod ->
313 case mode of
314 Name.Debug _ ->
315 "_UNUSED" <> builder
317 Name.Prod _ _ ->
318 builder
322-- GENERATE ENUM
325generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
326generateEnum mode (Opt.Global home name) ctorName index =
327 let
328 definition =
329 case mode of
330 Name.Debug _ ->
331 Expr.codeToExpr (Expr.generateCtor mode ctorName index 0)
333 Name.Prod _ _ ->
334 JS.Int (Index.toMachine index)
335 in
336 JS.Var [ (Name.fromGlobal home name, Just definition) ]
340-- GENERATE BOX
343generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
344generateBox mode (Opt.Global home name) ctorName =
345 let
346 definition =
347 case mode of
348 Name.Debug _ ->
349 Expr.codeToExpr (Expr.generateCtor mode ctorName Index.first 1)
351 Name.Prod _ _ ->
352 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
353 in
354 JS.Var [ (Name.fromGlobal home name, Just definition) ]
358-- GENERATE PORTS
361generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
362generatePort mode (Opt.Global home name) makePort converter =
363 let
364 definition =
365 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
366 [ JS.String (N.toBuilder name)
367 , Expr.codeToExpr (Expr.generate mode converter)
368 ]
369 in
370 JS.Var [ (Name.fromGlobal home name, Just definition) ]
374-- GENERATE MANAGER
377generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
378generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
379 let
380 managerLVar =
381 JS.LBracket
382 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
383 (JS.String (N.toBuilder moduleName))
385 (deps, args, stmts) =
386 generateManagerHelp home effectsType
388 createManager =
389 JS.ExprStmt $ JS.Assign managerLVar $
390 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
391 in
392 addStmt (List.foldl' (addGlobal mode graph) state deps) $
393 JS.Block (createManager : stmts)
396generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
397generateLeaf home@(ModuleName.Canonical _ moduleName) name =
398 let
399 definition =
400 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
401 in
402 JS.Var [ (Name.fromGlobal home name, Just definition) ]
405{-# NOINLINE leaf #-}
406leaf :: JS.Expr
407leaf =
408 JS.Ref (Name.fromKernel N.platform "leaf")
411generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
412generateManagerHelp home effectsType =
413 let
414 dep name = Opt.Global home name
415 ref name = JS.Ref (Name.fromGlobal home name)
416 in
417 case effectsType of
418 Opt.Cmd ->
419 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
420 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
421 , [ generateLeaf home "command" ]
422 )
424 Opt.Sub ->
425 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
426 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
427 , [ generateLeaf home "subscription" ]
428 )
430 Opt.Fx ->
431 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
432 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
433 , [ generateLeaf home "command"
434 , generateLeaf home "subscription"
435 ]
436 )
440-- MAIN EXPORTS
443toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
444toMainExports mode interfaces mains =
445 let
446 export =
447 Name.fromKernel N.platform "export"
449 exports =
450 generateExports mode interfaces $
451 Map.foldrWithKey addToTrie emptyTrie mains
452 in
453 Name.toBuilder export <> "(" <> exports <> ");"
456generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
457generateExports mode interfaces (Trie maybeMain subs) =
458 let
459 object =
460 case Map.toList subs of
461 [] ->
462 "{}"
464 (name, subTrie) : otherSubTries ->
465 "{'" <> Text.encodeUtf8Builder name <> "':"
466 <> generateExports mode interfaces subTrie
467 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
468 in
469 case maybeMain of
470 Nothing ->
471 object
473 Just (home, main) ->
474 let initialize = Expr.generateMain mode interfaces home main in
475 JS.exprToBuilder initialize <> "(" <> object <> ")"
478addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (Text.Text, Trie) -> B.Builder
479addSubTrie mode interfaces end (name, trie) =
480 ",'" <> Text.encodeUtf8Builder name <> "':"
481 <> generateExports mode interfaces trie
482 <> end
486-- BUILD TRIES
489data Trie =
490 Trie
491 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
492 , _subs :: Map.Map Text.Text Trie
493 }
496emptyTrie :: Trie
497emptyTrie =
498 Trie Nothing Map.empty
501addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
502addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
503 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
506segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
507segmentsToTrie home segments main =
508 case segments of
509 [] ->
510 Trie (Just (home, main)) Map.empty
512 segment : otherSegments ->
513 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
516merge :: Trie -> Trie -> Trie
517merge (Trie main1 subs1) (Trie main2 subs2) =
518 Trie
519 (checkedMerge main1 main2)
520 (Map.unionWith merge subs1 subs2)
523checkedMerge :: Maybe a -> Maybe a -> Maybe a
524checkedMerge a b =
525 case (a, b) of
526 (Nothing, main) ->
527 main
529 (main, Nothing) ->
530 main
532 (Just _, Just _) ->
533 error "cannot have two modules with the same name"