git.iko.soy/elk
on 19ff114 help sign in
elk/src/Generate/JavaScript.hs
521 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
20import qualified AST.Optimized as Opt
21import qualified AST.Module.Name as ModuleName
22import qualified Data.Index as Index
23import qualified Elm.Compiler.Type as Type
24import qualified Elm.Compiler.Type.Extract as Extract
25import qualified Elm.Interface as I
26import qualified Elm.Name as N
27import qualified Generate.JavaScript.Builder as JS
28import qualified Generate.JavaScript.Expression as Expr
29import qualified Generate.JavaScript.Name as Name
33-- GENERATE MAINS
36data Mode = Debug | Prod
39generate :: Mode -> Name.Target -> I.Interfaces -> Opt.Graph -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] B.Builder
40generate mode target interfaces (Opt.Graph mains graph fields) roots =
41 let
42 rootSet = Set.fromList roots
43 rootMap = Map.restrictKeys mains rootSet
44 in
45 if Map.size rootMap == Set.size rootSet then
46 let
47 realMode = toRealMode mode target fields
48 state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap
49 in
50 Right $ stateToBuilder state <> toMainExports realMode interfaces rootMap
52 else
53 Left $ Set.toList $
54 Set.intersection rootSet (Map.keysSet mains)
57addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
58addMain mode graph home _ state =
59 addGlobal mode graph state (Opt.Global home "main")
62toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
63toRealMode mode target fields =
64 case mode of
65 Debug ->
66 Name.Debug target
68 Prod ->
69 Name.Prod target (Name.shortenFieldNames fields)
73-- GENERATE FOR REPL
76generateForRepl :: I.Interfaces -> Opt.Graph -> ModuleName.Canonical -> N.Name -> B.Builder
77generateForRepl interfaces (Opt.Graph _ graph _) home name =
78 let
79 mode = Name.Debug Name.Server
80 eval = addGlobal mode graph emptyState (Opt.Global home name)
81 in
82 stateToBuilder eval <> print interfaces home name
85print :: I.Interfaces -> ModuleName.Canonical -> N.Name -> B.Builder
86print interfaces home name =
87 let
88 value = Name.toBuilder (Name.fromGlobal home name)
89 toString = Name.toBuilder (Name.fromKernel N.debug "toString")
90 annotation = I._types (interfaces ! home) ! name
91 tipe = Type.toString Type.MultiLine $ Extract.fromAnnotation annotation
92 in
93 "var _value = " <> toString <> "(" <> value <> ");\n" <>
94 "var _type = '" <> B.stringUtf8 (show tipe) <> "';\n\
95 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
96 \ console.log(_value + '\\n : ' + _type.split('\\n').join('\\n '));\n\
97 \} else {\n\
98 \ console.log(_value + ' : ' + _type);\n\
99 \}\n"
103-- GRAPH TRAVERSAL STATE
106data State =
107 State
108 { _revBuilders :: [B.Builder]
109 , _seenGlobals :: Set.Set Opt.Global
110 }
113emptyState :: State
114emptyState =
115 State [] Set.empty
118stateToBuilder :: State -> B.Builder
119stateToBuilder (State revBuilders _) =
120 List.foldl1' (\builder b -> b <> builder) revBuilders
124-- ADD DEPENDENCIES
127type Graph = Map.Map Opt.Global Opt.Node
130addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
131addGlobal mode graph state@(State builders seen) global =
132 if Set.member global seen then
133 state
134 else
135 addGlobalHelp mode graph global $
136 State builders (Set.insert global seen)
139addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
140addGlobalHelp mode graph global state =
141 let
142 addDeps deps someState =
143 Set.foldl' (addGlobal mode graph) someState deps
144 in
145 case graph ! global of
146 Opt.Define expr deps ->
147 addStmt (addDeps deps state) (
148 var global (Expr.generate mode expr)
149 )
151 Opt.DefineTailFunc argNames body deps ->
152 addStmt (addDeps deps state) (
153 generateTailDef mode global argNames body
154 )
156 Opt.Ctor name index arity ->
157 addStmt state (
158 var global (Expr.generateCtor mode name 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 case maybeServer of
174 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
175 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
177 _ ->
178 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
180 Opt.Enum name index ->
181 addStmt state (
182 generateEnum mode global name index
183 )
185 Opt.Box name ->
186 addStmt state (
187 generateBox mode global name
188 )
190 Opt.PortIncoming decoder deps ->
191 addStmt (addDeps deps state) (
192 generatePort mode global "incomingPort" decoder
193 )
195 Opt.PortOutgoing encoder deps ->
196 addStmt (addDeps deps state) (
197 generatePort mode global "outgoingPort" encoder
198 )
201addStmt :: State -> JS.Stmt -> State
202addStmt state stmt =
203 addBuilder state (JS.stmtToBuilder stmt)
206addBuilder :: State -> B.Builder -> State
207addBuilder (State revBuilders seen) builder =
208 State (builder:revBuilders) seen
211var :: Opt.Global -> Expr.Code -> JS.Stmt
212var (Opt.Global home name) code =
213 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
217-- GENERATE TAIL DEFS
220generateTailDef :: Name.Mode -> Opt.Global -> [N.Name] -> Opt.Expr -> JS.Stmt
221generateTailDef mode (Opt.Global home name) argNames body =
222 let
223 definition =
224 Expr.generateTailDef mode name argNames body
225 in
226 JS.Var [ (Name.fromGlobal home name, Just definition) ]
230-- GENERATE CYCLES
233generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
234generateCycle mode (Opt.Global home _) cycle =
235 let
236 safeDefs = map (generateSafeCycle mode home) cycle
237 realDefs = map (generateRealCycle home) cycle
238 -- TODO add `try` in debug mode nice infinite recursion reports
239 in
240 JS.Block (safeDefs ++ realDefs)
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 ]
263-- GENERATE KERNEL
266generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
267generateKernel mode chunks =
268 List.foldl' (addChunk mode) mempty chunks
271addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
272addChunk mode builder chunk =
273 case chunk of
274 Opt.JS javascript ->
275 B.byteString javascript <> builder
277 Opt.ElmVar home name ->
278 Name.toBuilder (Name.fromGlobal home name) <> builder
280 Opt.JsVar home name ->
281 Name.toBuilder (Name.fromKernel home name) <> builder
283 Opt.ElmField name ->
284 Name.toBuilder (Name.fromField mode name) <> builder
286 Opt.JsField int ->
287 Name.toBuilder (Name.fromInt int) <> builder
289 Opt.JsEnum int ->
290 Name.toBuilder (Name.fromInt int) <> builder
292 Opt.Debug ->
293 case mode of
294 Name.Debug _ ->
295 builder
297 Name.Prod _ _ ->
298 "_UNUSED" <> builder
300 Opt.Prod ->
301 case mode of
302 Name.Debug _ ->
303 "_UNUSED" <> builder
305 Name.Prod _ _ ->
306 builder
310-- GENERATE ENUM
313generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
314generateEnum mode (Opt.Global home name) ctorName index =
315 let
316 definition =
317 case mode of
318 Name.Debug _ ->
319 JS.Object [(Name.dollar, JS.String (N.toBuilder ctorName))]
321 Name.Prod _ _ ->
322 JS.Int (Index.toMachine index)
323 in
324 JS.Var [ (Name.fromGlobal home name, Just definition) ]
328-- GENERATE BOX
331generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
332generateBox mode (Opt.Global home name) ctorName =
333 let
334 definition =
335 case mode of
336 Name.Debug _ ->
337 Expr.codeToExpr $ Expr.generateCtor mode ctorName Index.first 1
339 Name.Prod _ _ ->
340 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
341 in
342 JS.Var [ (Name.fromGlobal home name, Just definition) ]
346-- GENERATE PORTS
349generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
350generatePort mode (Opt.Global home name) makePort converter =
351 let
352 definition =
353 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
354 [ JS.String (N.toBuilder name)
355 , Expr.codeToExpr (Expr.generate mode converter)
356 ]
357 in
358 JS.Var [ (Name.fromGlobal home name, Just definition) ]
362-- GENERATE MANAGER
365generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
366generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
367 let
368 managerLVar =
369 JS.LBracket
370 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
371 (JS.String (N.toBuilder moduleName))
373 (deps, args, stmts) =
374 generateManagerHelp home effectsType
376 createManager =
377 JS.ExprStmt $ JS.Assign managerLVar $
378 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
379 in
380 addStmt (List.foldl' (addGlobal mode graph) state deps) $
381 JS.Block (createManager : stmts)
384generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
385generateLeaf home@(ModuleName.Canonical _ moduleName) name =
386 let
387 definition =
388 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
389 in
390 JS.Var [ (Name.fromGlobal home name, Just definition) ]
393{-# NOINLINE leaf #-}
394leaf :: JS.Expr
395leaf =
396 JS.Ref (Name.fromKernel N.platform "leaf")
399generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
400generateManagerHelp home effectsType =
401 let
402 dep name = Opt.Global home name
403 ref name = JS.Ref (Name.fromGlobal home name)
404 in
405 case effectsType of
406 Opt.Cmd ->
407 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
408 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
409 , [ generateLeaf home "command" ]
410 )
412 Opt.Sub ->
413 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
414 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
415 , [ generateLeaf home "subscription" ]
416 )
418 Opt.Fx ->
419 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
420 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
421 , [ generateLeaf home "command"
422 , generateLeaf home "subscription"
423 ]
424 )
428-- MAIN EXPORTS
431toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
432toMainExports mode interfaces mains =
433 let
434 export =
435 Name.fromKernel N.platform "export"
437 exports =
438 generateExports mode interfaces $
439 Map.foldrWithKey addToTrie emptyTrie mains
440 in
441 Name.toBuilder export <> "(" <> exports <> ");"
444generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
445generateExports mode interfaces (Trie maybeMain subs) =
446 let
447 object =
448 case Map.toList subs of
449 [] ->
450 "{}"
452 (name, subTrie) : otherSubTries ->
453 "{'" <> N.toBuilder name <> "':"
454 <> generateExports mode interfaces subTrie
455 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
456 in
457 case maybeMain of
458 Nothing ->
459 object
461 Just (home, main) ->
462 let initialize = Expr.generateMain mode interfaces home main in
463 JS.exprToBuilder initialize <> "(" <> object <> ")"
466addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (N.Name, Trie) -> B.Builder
467addSubTrie mode interfaces end (name, trie) =
468 ",'" <> N.toBuilder name <> "':"
469 <> generateExports mode interfaces trie
470 <> end
474-- BUILD TRIES
477data Trie =
478 Trie
479 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
480 , _subs :: Map.Map N.Name Trie
481 }
484emptyTrie :: Trie
485emptyTrie =
486 Trie Nothing Map.empty
489addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
490addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
491 merge trie $ segmentsToTrie home (Text.splitOn "." moduleName) main
494segmentsToTrie :: ModuleName.Canonical -> [N.Name] -> Opt.Main -> Trie
495segmentsToTrie home segments main =
496 case segments of
497 [] ->
498 Trie (Just (home, main)) Map.empty
500 segment : otherSegments ->
501 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
504merge :: Trie -> Trie -> Trie
505merge (Trie main1 subs1) (Trie main2 subs2) =
506 Trie
507 (checkedMerge main1 main2)
508 (Map.unionWith merge subs1 subs2)
511checkedMerge :: Maybe a -> Maybe a -> Maybe a
512checkedMerge a b =
513 case (a, b) of
514 (Nothing, main) ->
515 main
517 (main, Nothing) ->
518 main
520 (Just _, Just _) ->
521 error "cannot have two modules with the same name"