git.iko.soy/elk
on 4953132 help sign in
elk/src/Generate/JavaScript.hs
505 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 let (Opt.Global _ name) = global in
154 var global (Expr.generateTailDef mode name argNames body)
155 )
157 Opt.Ctor name index arity ->
158 addStmt state (
159 var global (Expr.generateCtor mode name index arity)
160 )
162 Opt.Link linkedGlobal ->
163 addGlobal mode graph state linkedGlobal
165 Opt.Cycle cycle deps ->
166 addStmt (addDeps deps state) (
167 generateCycle mode global cycle
168 )
170 Opt.Manager effectsType ->
171 generateManager mode graph global effectsType state
173 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
174 case maybeServer of
175 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
176 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
178 _ ->
179 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
181 Opt.Enum name index ->
182 addStmt state (
183 generateEnum mode global name index
184 )
186 Opt.Box name ->
187 addStmt state (
188 generateBox mode global name
189 )
191 Opt.PortIncoming decoder deps ->
192 addStmt (addDeps deps state) (
193 generatePort mode global "incomingPort" decoder
194 )
196 Opt.PortOutgoing encoder deps ->
197 addStmt (addDeps deps state) (
198 generatePort mode global "outgoingPort" encoder
199 )
202addStmt :: State -> JS.Stmt -> State
203addStmt state stmt =
204 addBuilder state (JS.stmtToBuilder stmt)
207addBuilder :: State -> B.Builder -> State
208addBuilder (State revBuilders seen) builder =
209 State (builder:revBuilders) seen
212var :: Opt.Global -> Expr.Code -> JS.Stmt
213var (Opt.Global home name) code =
214 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
218-- GENERATE CYCLES
221generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
222generateCycle mode (Opt.Global home _) cycle =
223 let
224 safeDefs = map (generateSafeCycle mode home) cycle
225 realDefs = map (generateRealCycle home) cycle
226 -- TODO add `try` in debug mode nice infinite recursion reports
227 in
228 JS.Block (safeDefs ++ realDefs)
231generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
232generateSafeCycle mode home (name, expr) =
233 JS.FunctionStmt (Name.fromCycle home name) [] $
234 Expr.codeToStmtList (Expr.generate mode expr)
237generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
238generateRealCycle home (name, _) =
239 let
240 safeName = Name.fromCycle home name
241 realName = Name.fromGlobal home name
242 in
243 JS.Block
244 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
245 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
246 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
247 ]
251-- GENERATE KERNEL
254generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
255generateKernel mode chunks =
256 List.foldl' (addChunk mode) mempty chunks
259addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
260addChunk mode builder chunk =
261 case chunk of
262 Opt.JS javascript ->
263 B.byteString javascript <> builder
265 Opt.ElmVar home name ->
266 Name.toBuilder (Name.fromGlobal home name) <> builder
268 Opt.JsVar home name ->
269 Name.toBuilder (Name.fromKernel home name) <> builder
271 Opt.ElmField name ->
272 Name.toBuilder (Name.fromField mode name) <> builder
274 Opt.JsField int ->
275 Name.toBuilder (Name.fromInt int) <> builder
277 Opt.JsEnum int ->
278 B.intDec int <> builder
280 Opt.Debug ->
281 case mode of
282 Name.Debug _ ->
283 builder
285 Name.Prod _ _ ->
286 "_UNUSED" <> builder
288 Opt.Prod ->
289 case mode of
290 Name.Debug _ ->
291 "_UNUSED" <> builder
293 Name.Prod _ _ ->
294 builder
298-- GENERATE ENUM
301generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt
302generateEnum mode (Opt.Global home name) ctorName index =
303 let
304 definition =
305 case mode of
306 Name.Debug _ ->
307 JS.Object [(Name.dollar, JS.String (N.toBuilder ctorName))]
309 Name.Prod _ _ ->
310 JS.Int (Index.toMachine index)
311 in
312 JS.Var [ (Name.fromGlobal home name, Just definition) ]
316-- GENERATE BOX
319generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
320generateBox mode global ctorName =
321 case mode of
322 Name.Debug _ ->
323 var global (Expr.generateCtor mode ctorName Index.first 1)
325 Name.Prod _ _ ->
326 JS.EmptyStmt
330-- GENERATE PORTS
333generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
334generatePort mode (Opt.Global home name) makePort converter =
335 let
336 definition =
337 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
338 [ JS.String (N.toBuilder name)
339 , Expr.codeToExpr (Expr.generate mode converter)
340 ]
341 in
342 JS.Var [ (Name.fromGlobal home name, Just definition) ]
346-- GENERATE MANAGER
349generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
350generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
351 let
352 managerLVar =
353 JS.LBracket
354 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
355 (JS.String (N.toBuilder moduleName))
357 (deps, args, stmts) =
358 generateManagerHelp home effectsType
360 createManager =
361 JS.ExprStmt $ JS.Assign managerLVar $
362 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
363 in
364 addStmt (List.foldl' (addGlobal mode graph) state deps) $
365 JS.Block (createManager : stmts)
368generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
369generateLeaf home@(ModuleName.Canonical _ moduleName) name =
370 let
371 definition =
372 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
373 in
374 JS.Var [ (Name.fromGlobal home name, Just definition) ]
377{-# NOINLINE leaf #-}
378leaf :: JS.Expr
379leaf =
380 JS.Ref (Name.fromKernel N.platform "leaf")
383generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
384generateManagerHelp home effectsType =
385 let
386 dep name = Opt.Global home name
387 ref name = JS.Ref (Name.fromGlobal home name)
388 in
389 case effectsType of
390 Opt.Cmd ->
391 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
392 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
393 , [ generateLeaf home "command" ]
394 )
396 Opt.Sub ->
397 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
398 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
399 , [ generateLeaf home "subscription" ]
400 )
402 Opt.Fx ->
403 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
404 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
405 , [ generateLeaf home "command"
406 , generateLeaf home "subscription"
407 ]
408 )
412-- MAIN EXPORTS
415toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
416toMainExports mode interfaces mains =
417 let
418 export =
419 Name.fromKernel N.platform "export"
421 exports =
422 generateExports mode interfaces $
423 Map.foldrWithKey addToTrie emptyTrie mains
424 in
425 Name.toBuilder export <> "(" <> exports <> ");"
428generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
429generateExports mode interfaces (Trie maybeMain subs) =
430 let
431 object =
432 case Map.toList subs of
433 [] ->
434 "{}"
436 (name, subTrie) : otherSubTries ->
437 "{'" <> N.toBuilder name <> "':"
438 <> generateExports mode interfaces subTrie
439 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
440 in
441 case maybeMain of
442 Nothing ->
443 object
445 Just (home, main) ->
446 let initialize = Expr.generateMain mode interfaces home main in
447 JS.exprToBuilder initialize <> "(" <> object <> ")"
450addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (N.Name, Trie) -> B.Builder
451addSubTrie mode interfaces end (name, trie) =
452 ",'" <> N.toBuilder name <> "':"
453 <> generateExports mode interfaces trie
454 <> end
458-- BUILD TRIES
461data Trie =
462 Trie
463 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
464 , _subs :: Map.Map N.Name Trie
465 }
468emptyTrie :: Trie
469emptyTrie =
470 Trie Nothing Map.empty
473addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
474addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
475 merge trie $ segmentsToTrie home (Text.splitOn "." moduleName) main
478segmentsToTrie :: ModuleName.Canonical -> [N.Name] -> Opt.Main -> Trie
479segmentsToTrie home segments main =
480 case segments of
481 [] ->
482 Trie (Just (home, main)) Map.empty
484 segment : otherSegments ->
485 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
488merge :: Trie -> Trie -> Trie
489merge (Trie main1 subs1) (Trie main2 subs2) =
490 Trie
491 (checkedMerge main1 main2)
492 (Map.unionWith merge subs1 subs2)
495checkedMerge :: Maybe a -> Maybe a -> Maybe a
496checkedMerge a b =
497 case (a, b) of
498 (Nothing, main) ->
499 main
501 (main, Nothing) ->
502 main
504 (Just _, Just _) ->
505 error "cannot have two modules with the same name"