git.iko.soy/elk
on 83e18b3 help sign in
elk/src/Generate/JavaScript.hs
506 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 (Opt.Global home name) ctorName index =
304 let
305 definition =
306 case mode of
307 Name.Debug _ ->
308 JS.Object [(Name.dollar, JS.String (N.toBuilder ctorName))]
310 Name.Prod _ _ ->
311 JS.Int (Index.toMachine index)
312 in
313 JS.Var [ (Name.fromGlobal home name, Just definition) ]
317-- GENERATE BOX
320generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt
321generateBox mode global ctorName =
322 case mode of
323 Name.Debug _ ->
324 var global (Expr.generateCtor mode ctorName Index.first 1)
326 Name.Prod _ _ ->
327 JS.EmptyStmt
331-- GENERATE PORTS
334generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
335generatePort mode (Opt.Global home name) makePort converter =
336 let
337 definition =
338 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
339 [ JS.String (N.toBuilder name)
340 , Expr.codeToExpr (Expr.generate mode converter)
341 ]
342 in
343 JS.Var [ (Name.fromGlobal home name, Just definition) ]
347-- GENERATE MANAGER
350generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
351generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
352 let
353 managerLVar =
354 JS.LBracket
355 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
356 (JS.String (N.toBuilder moduleName))
358 (deps, args, stmts) =
359 generateManagerHelp home effectsType
361 createManager =
362 JS.ExprStmt $ JS.Assign managerLVar $
363 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
364 in
365 addStmt (List.foldl' (addGlobal mode graph) state deps) $
366 JS.Block (createManager : stmts)
369generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
370generateLeaf home@(ModuleName.Canonical _ moduleName) name =
371 let
372 definition =
373 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
374 in
375 JS.Var [ (Name.fromGlobal home name, Just definition) ]
378{-# NOINLINE leaf #-}
379leaf :: JS.Expr
380leaf =
381 JS.Ref (Name.fromKernel N.platform "leaf")
384generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
385generateManagerHelp home effectsType =
386 let
387 dep name = Opt.Global home name
388 ref name = JS.Ref (Name.fromGlobal home name)
389 in
390 case effectsType of
391 Opt.Cmd ->
392 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
393 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
394 , [ generateLeaf home "command" ]
395 )
397 Opt.Sub ->
398 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
399 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
400 , [ generateLeaf home "subscription" ]
401 )
403 Opt.Fx ->
404 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
405 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
406 , [ generateLeaf home "command"
407 , generateLeaf home "subscription"
408 ]
409 )
413-- MAIN EXPORTS
416toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
417toMainExports mode interfaces mains =
418 let
419 export =
420 Name.fromKernel N.platform "export"
422 exports =
423 generateExports mode interfaces $
424 Map.foldrWithKey addToTrie emptyTrie mains
425 in
426 Name.toBuilder export <> "(" <> exports <> ");"
429generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
430generateExports mode interfaces (Trie maybeMain subs) =
431 let
432 object =
433 case Map.toList subs of
434 [] ->
435 "{}"
437 (name, subTrie) : otherSubTries ->
438 "{'" <> Text.encodeUtf8Builder name <> "':"
439 <> generateExports mode interfaces subTrie
440 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
441 in
442 case maybeMain of
443 Nothing ->
444 object
446 Just (home, main) ->
447 let initialize = Expr.generateMain mode interfaces home main in
448 JS.exprToBuilder initialize <> "(" <> object <> ")"
451addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (Text.Text, Trie) -> B.Builder
452addSubTrie mode interfaces end (name, trie) =
453 ",'" <> Text.encodeUtf8Builder name <> "':"
454 <> generateExports mode interfaces trie
455 <> end
459-- BUILD TRIES
462data Trie =
463 Trie
464 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
465 , _subs :: Map.Map Text.Text Trie
466 }
469emptyTrie :: Trie
470emptyTrie =
471 Trie Nothing Map.empty
474addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
475addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
476 merge trie $ segmentsToTrie home (Text.splitOn "." (N.toText moduleName)) main
479segmentsToTrie :: ModuleName.Canonical -> [Text.Text] -> Opt.Main -> Trie
480segmentsToTrie home segments main =
481 case segments of
482 [] ->
483 Trie (Just (home, main)) Map.empty
485 segment : otherSegments ->
486 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
489merge :: Trie -> Trie -> Trie
490merge (Trie main1 subs1) (Trie main2 subs2) =
491 Trie
492 (checkedMerge main1 main2)
493 (Map.unionWith merge subs1 subs2)
496checkedMerge :: Maybe a -> Maybe a -> Maybe a
497checkedMerge a b =
498 case (a, b) of
499 (Nothing, main) ->
500 main
502 (main, Nothing) ->
503 main
505 (Just _, Just _) ->
506 error "cannot have two modules with the same name"