git.iko.soy/elk
on be60233 help sign in
elk/src/Generate/JavaScript.hs
502 lines 13 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
34-- GENERATE MAINS
37data Mode = Debug | Prod
40generate :: Mode -> Name.Target -> I.Interfaces -> Opt.Graph -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] B.Builder
41generate mode target interfaces (Opt.Graph mains graph fields) roots =
42 let
43 rootSet = Set.fromList roots
44 rootMap = Map.restrictKeys mains rootSet
45 in
46 if Map.size rootMap == Set.size rootSet then
47 let
48 realMode = toRealMode mode target fields
49 state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap
50 in
51 Right $ stateToBuilder state <> toMainExports realMode interfaces rootMap
53 else
54 Left $ Set.toList $
55 Set.intersection rootSet (Map.keysSet mains)
58addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
59addMain mode graph home _ state =
60 addGlobal mode graph state (Opt.Global home "main")
63toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
64toRealMode mode target fields =
65 case mode of
66 Debug ->
67 Name.Debug target
69 Prod ->
70 Name.Prod target (Name.shortenFieldNames fields)
74-- GENERATE FOR REPL
77generateForRepl :: I.Interfaces -> Opt.Graph -> ModuleName.Canonical -> N.Name -> B.Builder
78generateForRepl interfaces (Opt.Graph _ graph _) home name =
79 let
80 mode = Name.Debug Name.Server
81 eval = addGlobal mode graph emptyState (Opt.Global home name)
82 in
83 stateToBuilder eval <> print interfaces home name
86print :: I.Interfaces -> ModuleName.Canonical -> N.Name -> B.Builder
87print interfaces home name =
88 let
89 value = Name.toBuilder (Name.fromGlobal home name)
90 toString = Name.toBuilder (Name.fromKernel N.debug "toString")
91 annotation = I._types (interfaces ! home) ! name
92 tipe = Type.toString Type.MultiLine $ Extract.fromAnnotation annotation
93 in
94 "var _value = " <> toString <> "(" <> value <> ");\n" <>
95 "var _type = '" <> B.stringUtf8 (show tipe) <> "';\n\
96 \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
97 \ console.log(_value + '\\n : ' + _type.split('\\n').join('\\n '));\n\
98 \} else {\n\
99 \ console.log(_value + ' : ' + _type);\n\
100 \}\n"
104-- GRAPH TRAVERSAL STATE
107data State =
108 State
109 { _revBuilders :: [B.Builder]
110 , _seenGlobals :: Set.Set Opt.Global
111 }
114emptyState :: State
115emptyState =
116 State [] Set.empty
119stateToBuilder :: State -> B.Builder
120stateToBuilder (State revBuilders _) =
121 List.foldl1' (\builder b -> b <> builder) revBuilders
125-- ADD DEPENDENCIES
128type Graph = Map.Map Opt.Global Opt.Node
131addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
132addGlobal mode graph state@(State builders seen) global =
133 if Set.member global seen then
134 state
135 else
136 addGlobalHelp mode graph global $
137 State builders (Set.insert global seen)
140addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
141addGlobalHelp mode graph global state =
142 let
143 addDeps deps someState =
144 Set.foldl' (addGlobal mode graph) someState deps
145 in
146 case graph ! global of
147 Opt.Define expr deps ->
148 addStmt (addDeps deps state) (
149 var global (Expr.generate mode expr)
150 )
152 Opt.DefineTailFunc argNames body deps ->
153 addStmt (addDeps deps state) (
154 let (Opt.Global _ name) = global in
155 var global (Expr.generateTailDef mode name argNames body)
156 )
158 Opt.Ctor name index arity ->
159 addStmt state (
160 var global (Expr.generateCtor mode name index arity)
161 )
163 Opt.Link linkedGlobal ->
164 addGlobal mode graph state linkedGlobal
166 Opt.Cycle cycle deps ->
167 addStmt (addDeps deps state) (
168 generateCycle mode global cycle
169 )
171 Opt.Manager effectsType ->
172 generateManager mode graph global effectsType state
174 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
175 case maybeServer of
176 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
177 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
179 _ ->
180 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
182 Opt.Enum name index ->
183 addStmt state (
184 generateEnum mode global name index
185 )
187 Opt.Box name ->
188 addStmt state (
189 generateBox mode global name
190 )
192 Opt.PortIncoming decoder deps ->
193 addStmt (addDeps deps state) (
194 generatePort mode global "incomingPort" decoder
195 )
197 Opt.PortOutgoing encoder deps ->
198 addStmt (addDeps deps state) (
199 generatePort mode global "outgoingPort" encoder
200 )
203addStmt :: State -> JS.Stmt -> State
204addStmt state stmt =
205 addBuilder state (JS.stmtToBuilder stmt)
208addBuilder :: State -> B.Builder -> State
209addBuilder (State revBuilders seen) builder =
210 State (builder:revBuilders) seen
213var :: Opt.Global -> Expr.Code -> JS.Stmt
214var (Opt.Global home name) code =
215 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
219-- GENERATE CYCLES
222generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
223generateCycle mode (Opt.Global home _) cycle =
224 let
225 safeDefs = map (generateSafeCycle mode home) cycle
226 realDefs = map (generateRealCycle home) cycle
227 -- TODO add `try` in debug mode nice infinite recursion reports
228 in
229 JS.Block (safeDefs ++ realDefs)
232generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
233generateSafeCycle mode home (name, expr) =
234 JS.FunctionStmt (Name.fromCycle home name) [] $
235 Expr.codeToStmtList (Expr.generate mode expr)
238generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
239generateRealCycle home (name, _) =
240 let
241 safeName = Name.fromCycle home name
242 realName = Name.fromGlobal home name
243 in
244 JS.Block
245 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
246 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
247 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
248 ]
252-- GENERATE KERNEL
255generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
256generateKernel mode chunks =
257 List.foldl' (addChunk mode) mempty chunks
260addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
261addChunk mode builder chunk =
262 case chunk of
263 Opt.JS javascript ->
264 B.byteString javascript <> builder
266 Opt.ElmVar home name ->
267 Name.toBuilder (Name.fromGlobal home name) <> builder
269 Opt.JsVar home name ->
270 Name.toBuilder (Name.fromKernel home name) <> builder
272 Opt.ElmField name ->
273 Name.toBuilder (Name.fromField mode name) <> builder
275 Opt.JsField int ->
276 Name.toBuilder (Name.fromInt int) <> builder
278 Opt.JsEnum int ->
279 B.intDec int <> builder
281 Opt.Debug ->
282 case mode of
283 Name.Debug _ ->
284 builder
286 Name.Prod _ _ ->
287 "_UNUSED" <> builder
289 Opt.Prod ->
290 case mode of
291 Name.Debug _ ->
292 "_UNUSED" <> builder
294 Name.Prod _ _ ->
295 builder
299-- GENERATE ENUM
302generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
303generateEnum mode global ctorName index =
304 case mode of
305 Name.Debug _ ->
306 var global (Expr.generateCtor mode ctorName index 0)
308 Name.Prod _ _ ->
309 JS.EmptyStmt
313-- GENERATE BOX
316generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
317generateBox mode global ctorName =
318 case mode of
319 Name.Debug _ ->
320 var global (Expr.generateCtor mode ctorName Index.first 1)
322 Name.Prod _ _ ->
323 JS.EmptyStmt
327-- GENERATE PORTS
330generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
331generatePort mode (Opt.Global home name) makePort converter =
332 let
333 definition =
334 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
335 [ JS.String (N.toBuilder name)
336 , Expr.codeToExpr (Expr.generate mode converter)
337 ]
338 in
339 JS.Var [ (Name.fromGlobal home name, Just definition) ]
343-- GENERATE MANAGER
346generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
347generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
348 let
349 managerLVar =
350 JS.LBracket
351 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
352 (JS.String (N.toBuilder moduleName))
354 (deps, args, stmts) =
355 generateManagerHelp home effectsType
357 createManager =
358 JS.ExprStmt $ JS.Assign managerLVar $
359 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
360 in
361 addStmt (List.foldl' (addGlobal mode graph) state deps) $
362 JS.Block (createManager : stmts)
365generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
366generateLeaf home@(ModuleName.Canonical _ moduleName) name =
367 let
368 definition =
369 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
370 in
371 JS.Var [ (Name.fromGlobal home name, Just definition) ]
374{-# NOINLINE leaf #-}
375leaf :: JS.Expr
376leaf =
377 JS.Ref (Name.fromKernel N.platform "leaf")
380generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
381generateManagerHelp home effectsType =
382 let
383 dep name = Opt.Global home name
384 ref name = JS.Ref (Name.fromGlobal home name)
385 in
386 case effectsType of
387 Opt.Cmd ->
388 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
389 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
390 , [ generateLeaf home "command" ]
391 )
393 Opt.Sub ->
394 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
395 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
396 , [ generateLeaf home "subscription" ]
397 )
399 Opt.Fx ->
400 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
401 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
402 , [ generateLeaf home "command"
403 , generateLeaf home "subscription"
404 ]
405 )
409-- MAIN EXPORTS
412toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
413toMainExports mode interfaces mains =
414 let
415 export =
416 Name.fromKernel N.platform "export"
418 exports =
419 generateExports mode interfaces $
420 Map.foldrWithKey addToTrie emptyTrie mains
421 in
422 Name.toBuilder export <> "(" <> exports <> ");"
425generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
426generateExports mode interfaces (Trie maybeMain subs) =
427 let
428 object =
429 case Map.toList subs of
430 [] ->
431 "{}"
433 (name, subTrie) : otherSubTries ->
434 "{'" <> Text.encodeUtf8Builder name <> "':"
435 <> generateExports mode interfaces subTrie
436 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
437 in
438 case maybeMain of
439 Nothing ->
440 object
442 Just (home, main) ->
443 let initialize = Expr.generateMain mode interfaces home main in
444 JS.exprToBuilder initialize <> "(" <> object <> ")"
447addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (Text.Text, Trie) -> B.Builder
448addSubTrie mode interfaces end (name, trie) =
449 ",'" <> Text.encodeUtf8Builder name <> "':"
450 <> generateExports mode interfaces trie
451 <> end
455-- BUILD TRIES
458data Trie =
459 Trie
460 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
461 , _subs :: Map.Map Text.Text Trie
462 }
465emptyTrie :: Trie
466emptyTrie =
467 Trie Nothing Map.empty
470addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
471addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
472 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
475segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
476segmentsToTrie home segments main =
477 case segments of
478 [] ->
479 Trie (Just (home, main)) Map.empty
481 segment : otherSegments ->
482 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
485merge :: Trie -> Trie -> Trie
486merge (Trie main1 subs1) (Trie main2 subs2) =
487 Trie
488 (checkedMerge main1 main2)
489 (Map.unionWith merge subs1 subs2)
492checkedMerge :: Maybe a -> Maybe a -> Maybe a
493checkedMerge a b =
494 case (a, b) of
495 (Nothing, main) ->
496 main
498 (main, Nothing) ->
499 main
501 (Just _, Just _) ->
502 error "cannot have two modules with the same name"