git.iko.soy/elk
on 51e95e8 help sign in
elk/src/Generate/JavaScript.hs
508 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
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 var global (Expr.generateFunction (map Name.fromLocal argNames) (Expr.generate mode 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 CYCLES
220generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
221generateCycle mode (Opt.Global home _) cycle =
222 let
223 safeDefs = map (generateSafeCycle mode home) cycle
224 realDefs = map (generateRealCycle home) cycle
225 -- TODO add `try` in debug mode nice infinite recursion reports
226 in
227 JS.Block (safeDefs ++ realDefs)
230generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
231generateSafeCycle mode home (name, expr) =
232 JS.FunctionStmt (Name.fromCycle home name) [] $
233 Expr.codeToStmtList (Expr.generate mode expr)
236generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
237generateRealCycle home (name, _) =
238 let
239 safeName = Name.fromCycle home name
240 realName = Name.fromGlobal home name
241 in
242 JS.Block
243 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
244 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
245 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
246 ]
250-- GENERATE KERNEL
253generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
254generateKernel mode chunks =
255 List.foldl' (addChunk mode) mempty chunks
258addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
259addChunk mode builder chunk =
260 case chunk of
261 Opt.JS javascript ->
262 B.byteString javascript <> builder
264 Opt.ElmVar home name ->
265 Name.toBuilder (Name.fromGlobal home name) <> builder
267 Opt.JsVar home name ->
268 Name.toBuilder (Name.fromKernel home name) <> builder
270 Opt.ElmField name ->
271 Name.toBuilder (Name.fromField mode name) <> builder
273 Opt.JsField int ->
274 Name.toBuilder (Name.fromInt int) <> builder
276 Opt.JsEnum int ->
277 Name.toBuilder (Name.fromInt int) <> builder
279 Opt.Debug ->
280 case mode of
281 Name.Debug _ ->
282 builder
284 Name.Prod _ _ ->
285 "_UNUSED" <> builder
287 Opt.Prod ->
288 case mode of
289 Name.Debug _ ->
290 "_UNUSED" <> builder
292 Name.Prod _ _ ->
293 builder
297-- GENERATE ENUM
300generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
301generateEnum mode (Opt.Global home name) ctorName index =
302 let
303 definition =
304 case mode of
305 Name.Debug _ ->
306 JS.Object [(Name.dollar, JS.String (N.toBuilder ctorName))]
308 Name.Prod _ _ ->
309 JS.Int (Index.toMachine index)
310 in
311 JS.Var [ (Name.fromGlobal home name, Just definition) ]
315-- GENERATE BOX
318generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
319generateBox mode (Opt.Global home name) ctorName =
320 let
321 definition =
322 case mode of
323 Name.Debug _ ->
324 Expr.codeToExpr $ Expr.generateCtor mode ctorName Index.first 1
326 Name.Prod _ _ ->
327 JS.Ref (Name.fromGlobal ModuleName.basics N.identity)
328 in
329 JS.Var [ (Name.fromGlobal home name, Just definition) ]
333-- GENERATE PORTS
336generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
337generatePort mode (Opt.Global home name) makePort converter =
338 let
339 definition =
340 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
341 [ JS.String (N.toBuilder name)
342 , Expr.codeToExpr (Expr.generate mode converter)
343 ]
344 in
345 JS.Var [ (Name.fromGlobal home name, Just definition) ]
349-- GENERATE MANAGER
352generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
353generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
354 let
355 managerLVar =
356 JS.LBracket
357 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
358 (JS.String (N.toBuilder moduleName))
360 (deps, args, stmts) =
361 generateManagerHelp home effectsType
363 createManager =
364 JS.ExprStmt $ JS.Assign managerLVar $
365 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
366 in
367 addStmt (List.foldl' (addGlobal mode graph) state deps) $
368 JS.Block (createManager : stmts)
371generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
372generateLeaf home@(ModuleName.Canonical _ moduleName) name =
373 let
374 definition =
375 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
376 in
377 JS.Var [ (Name.fromGlobal home name, Just definition) ]
380{-# NOINLINE leaf #-}
381leaf :: JS.Expr
382leaf =
383 JS.Ref (Name.fromKernel N.platform "leaf")
386generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
387generateManagerHelp home effectsType =
388 let
389 dep name = Opt.Global home name
390 ref name = JS.Ref (Name.fromGlobal home name)
391 in
392 case effectsType of
393 Opt.Cmd ->
394 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
395 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
396 , [ generateLeaf home "command" ]
397 )
399 Opt.Sub ->
400 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
401 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
402 , [ generateLeaf home "subscription" ]
403 )
405 Opt.Fx ->
406 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
407 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
408 , [ generateLeaf home "command"
409 , generateLeaf home "subscription"
410 ]
411 )
415-- MAIN EXPORTS
418toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
419toMainExports mode interfaces mains =
420 let
421 export =
422 Name.fromKernel N.platform "export"
424 exports =
425 generateExports mode interfaces $
426 Map.foldrWithKey addToTrie emptyTrie mains
427 in
428 Name.toBuilder export <> "(" <> exports <> ");"
431generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
432generateExports mode interfaces (Trie maybeMain subs) =
433 let
434 object =
435 case Map.toList subs of
436 [] ->
437 "{}"
439 (name, subTrie) : otherSubTries ->
440 "{'" <> N.toBuilder name <> "':"
441 <> generateExports mode interfaces subTrie
442 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
443 in
444 case maybeMain of
445 Nothing ->
446 object
448 Just (home, main) ->
449 let initialize = Expr.generateMain mode interfaces home main in
450 JS.exprToBuilder initialize <> "(" <> object <> ")"
453addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (N.Name, Trie) -> B.Builder
454addSubTrie mode interfaces end (name, trie) =
455 ",'" <> N.toBuilder name <> "':"
456 <> generateExports mode interfaces trie
457 <> end
461-- BUILD TRIES
464data Trie =
465 Trie
466 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
467 , _subs :: Map.Map N.Name Trie
468 }
471emptyTrie :: Trie
472emptyTrie =
473 Trie Nothing Map.empty
476addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
477addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
478 merge trie $ segmentsToTrie home (Text.splitOn "." moduleName) main
481segmentsToTrie :: ModuleName.Canonical -> [N.Name] -> Opt.Main -> Trie
482segmentsToTrie home segments main =
483 case segments of
484 [] ->
485 Trie (Just (home, main)) Map.empty
487 segment : otherSegments ->
488 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
491merge :: Trie -> Trie -> Trie
492merge (Trie main1 subs1) (Trie main2 subs2) =
493 Trie
494 (checkedMerge main1 main2)
495 (Map.unionWith merge subs1 subs2)
498checkedMerge :: Maybe a -> Maybe a -> Maybe a
499checkedMerge a b =
500 case (a, b) of
501 (Nothing, main) ->
502 main
504 (main, Nothing) ->
505 main
507 (Just _, Just _) ->
508 error "cannot have two modules with the same name"