git.iko.soy/elk
on 422e250 help sign in
elk/src/Generate/JavaScript.hs
454 lines 12 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript
4 ( ReplBuilder(..)
5 , generateForRepl
6 , Mode(..)
7 , generate
8 )
9 where
12import Prelude hiding (cycle)
13import qualified Data.ByteString.Builder as B
14import Data.Monoid ((<>))
15import qualified Data.List as List
16import Data.Map ((!))
17import qualified Data.Map as Map
18import qualified Data.Set as Set
19import qualified Data.Text as Text
21import qualified AST.Optimized as Opt
22import qualified AST.Module.Name as ModuleName
23import qualified Elm.Interface as I
24import qualified Elm.Name as N
25import qualified Generate.JavaScript.Builder as JS
26import qualified Generate.JavaScript.Expression as Expr
27import qualified Generate.JavaScript.Name as Name
31-- GENERATE FOR REPL
34data ReplBuilder =
35 ReplBuilder
36 { _repl_code :: B.Builder
37 , _repl_name :: B.Builder
38 }
41generateForRepl :: Opt.Graph -> ModuleName.Canonical -> N.Name -> ReplBuilder
42generateForRepl (Opt.Graph _ graph _) home name =
43 ReplBuilder
44 { _repl_code =
45 stateToBuilder $
46 addGlobal (Name.Debug Name.Client) graph emptyState (Opt.Global home name)
47 , _repl_name =
48 Name.toBuilder (Name.fromGlobal home name)
49 }
53-- GENERATE MAINS
56data Mode = Debug | Prod
59generate :: Mode -> Name.Target -> Opt.Graph -> I.Interfaces -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] B.Builder
60generate mode target (Opt.Graph mains graph fields) interfaces roots =
61 let
62 rootSet = Set.fromList roots
63 rootMap = Map.restrictKeys mains rootSet
64 in
65 if Map.size rootMap == Set.size rootSet then
66 let
67 realMode = toRealMode mode target fields
68 state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap
69 in
70 Right $ stateToBuilder state <> toMainExports realMode interfaces rootMap
72 else
73 Left $ Set.toList $
74 Set.intersection rootSet (Map.keysSet mains)
77addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
78addMain mode graph home _ state =
79 addGlobal mode graph state (Opt.Global home "main")
82toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
83toRealMode mode target fields =
84 case mode of
85 Debug ->
86 Name.Debug target
88 Prod ->
89 Name.Prod target (Name.shortenFieldNames fields)
93-- GRAPH TRAVERSAL STATE
96data State =
97 State
98 { _revBuilders :: [B.Builder]
99 , _seenGlobals :: Set.Set Opt.Global
100 }
103emptyState :: State
104emptyState =
105 State [] Set.empty
108stateToBuilder :: State -> B.Builder
109stateToBuilder (State revBuilders _) =
110 List.foldl1' (\builder b -> b <> builder) revBuilders
114-- ADD DEPENDENCIES
117type Graph = Map.Map Opt.Global Opt.Node
120addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
121addGlobal mode graph state@(State builders seen) global =
122 if Set.member global seen then
123 state
124 else
125 addGlobalHelp mode graph global $
126 State builders (Set.insert global seen)
129addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
130addGlobalHelp mode graph global state =
131 let
132 addDeps deps someState =
133 Set.foldl' (addGlobal mode graph) someState deps
134 in
135 case graph ! global of
136 Opt.Define expr deps ->
137 addStmt (addDeps deps state) (
138 var global (Expr.generate mode expr)
139 )
141 Opt.DefineTailFunc argNames body deps ->
142 addStmt (addDeps deps state) (
143 var global (Expr.generateFunction (map Name.fromLocal argNames) (Expr.generate mode body))
144 )
146 Opt.Ctor name index arity ->
147 let (args, ctor) = Expr.generateCtor mode name index arity in
148 addStmt state (
149 var global (Expr.generateFunction args ctor)
150 )
152 Opt.Link linkedGlobal ->
153 addGlobal mode graph state linkedGlobal
155 Opt.Cycle cycle deps ->
156 addStmt (addDeps deps state) (
157 generateCycle mode global cycle
158 )
160 Opt.Manager effectsType ->
161 generateManager mode graph global effectsType state
163 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
164 case maybeServer of
165 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
166 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
168 _ ->
169 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
171 Opt.PortIncoming decoder deps ->
172 addStmt (addDeps deps state) (
173 generatePort mode global "incomingPort" decoder
174 )
176 Opt.PortOutgoing encoder deps ->
177 addStmt (addDeps deps state) (
178 generatePort mode global "outgoingPort" encoder
179 )
182addStmt :: State -> JS.Stmt -> State
183addStmt state stmt =
184 addBuilder state (JS.stmtToBuilder stmt)
187addBuilder :: State -> B.Builder -> State
188addBuilder (State revBuilders seen) builder =
189 State (builder:revBuilders) seen
192var :: Opt.Global -> Expr.Code -> JS.Stmt
193var (Opt.Global home name) code =
194 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
198-- GENERATE CYCLES
201generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
202generateCycle mode (Opt.Global home _) cycle =
203 let
204 safeDefs = map (generateSafeCycle mode home) cycle
205 realDefs = map (generateRealCycle home) cycle
206 -- TODO add `try` in debug mode nice infinite recursion reports
207 in
208 JS.Block (safeDefs ++ realDefs)
211generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
212generateSafeCycle mode home (name, expr) =
213 JS.FunctionStmt (Name.fromCycle home name) [] $
214 Expr.codeToStmtList (Expr.generate mode expr)
217generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
218generateRealCycle home (name, _) =
219 let
220 safeName = Name.fromCycle home name
221 realName = Name.fromGlobal home name
222 in
223 JS.Block
224 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
225 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
226 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
227 ]
231-- GENERATE KERNEL
234generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
235generateKernel mode chunks =
236 List.foldl' (addChunk mode) mempty chunks
239addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
240addChunk mode builder chunk =
241 case chunk of
242 Opt.JS javascript ->
243 B.byteString javascript <> builder
245 Opt.ElmVar home name ->
246 Name.toBuilder (Name.fromGlobal home name) <> builder
248 Opt.JsVar home name ->
249 Name.toBuilder (Name.fromKernel home name) <> builder
251 Opt.ElmField name ->
252 Name.toBuilder (Name.fromField mode name) <> builder
254 Opt.JsField int ->
255 Name.toBuilder (Name.fromInt int) <> builder
257 Opt.Enum int ->
258 Name.toBuilder (Name.fromInt int) <> builder
260 Opt.Debug ->
261 case mode of
262 Name.Debug _ ->
263 builder
265 Name.Prod _ _ ->
266 "_UNUSED" <> builder
268 Opt.Prod ->
269 case mode of
270 Name.Debug _ ->
271 "_UNUSED" <> builder
273 Name.Prod _ _ ->
274 builder
278-- GENERATE PORTS
281generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
282generatePort mode (Opt.Global home name) makePort converter =
283 let
284 definition =
285 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
286 [ JS.String (N.toBuilder name)
287 , Expr.codeToExpr (Expr.generate mode converter)
288 ]
289 in
290 JS.Var [ (Name.fromGlobal home name, Just definition) ]
294-- GENERATE MANAGER
298generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
299generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
300 let
301 managerLVar =
302 JS.LBracket
303 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
304 (JS.String (N.toBuilder moduleName))
306 (deps, args, stmts) =
307 generateManagerHelp home effectsType
309 createManager =
310 JS.ExprStmt $ JS.Assign managerLVar $
311 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
312 in
313 addStmt (List.foldl' (addGlobal mode graph) state deps) $
314 JS.Block (createManager : stmts)
317generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
318generateLeaf home@(ModuleName.Canonical _ moduleName) name =
319 let
320 definition =
321 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
322 in
323 JS.Var [ (Name.fromGlobal home name, Just definition) ]
326{-# NOINLINE leaf #-}
327leaf :: JS.Expr
328leaf =
329 JS.Ref (Name.fromKernel N.platform "leaf")
332generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
333generateManagerHelp home effectsType =
334 let
335 dep name = Opt.Global home name
336 ref name = JS.Ref (Name.fromGlobal home name)
337 in
338 case effectsType of
339 Opt.Cmd ->
340 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
341 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
342 , [ generateLeaf home "command" ]
343 )
345 Opt.Sub ->
346 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
347 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
348 , [ generateLeaf home "subscription" ]
349 )
351 Opt.Fx ->
352 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
353 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
354 , [ generateLeaf home "command"
355 , generateLeaf home "subscription"
356 ]
357 )
361-- MAIN EXPORTS
364toMainExports :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
365toMainExports mode interfaces mains =
366 let
367 export =
368 Name.fromKernel N.platform "export"
370 exports =
371 generateExports mode interfaces $
372 Map.foldrWithKey addToTrie emptyTrie mains
373 in
374 Name.toBuilder export <> "(" <> exports <> ");"
377generateExports :: Name.Mode -> I.Interfaces -> Trie -> B.Builder
378generateExports mode interfaces (Trie maybeMain subs) =
379 let
380 object =
381 case Map.toList subs of
382 [] ->
383 "{}"
385 (name, subTrie) : otherSubTries ->
386 "{'" <> N.toBuilder name <> "':"
387 <> generateExports mode interfaces subTrie
388 <> List.foldl' (addSubTrie mode interfaces) "}" otherSubTries
389 in
390 case maybeMain of
391 Nothing ->
392 object
394 Just (home, main) ->
395 let initialize = Expr.generateMain mode interfaces home main in
396 JS.exprToBuilder initialize <> "(" <> object <> ")"
399addSubTrie :: Name.Mode -> I.Interfaces -> B.Builder -> (N.Name, Trie) -> B.Builder
400addSubTrie mode interfaces end (name, trie) =
401 ",'" <> N.toBuilder name <> "':"
402 <> generateExports mode interfaces trie
403 <> end
407-- BUILD TRIES
410data Trie =
411 Trie
412 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
413 , _subs :: Map.Map N.Name Trie
414 }
417emptyTrie :: Trie
418emptyTrie =
419 Trie Nothing Map.empty
422addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
423addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
424 merge trie $ segmentsToTrie home (Text.splitOn "." moduleName) main
427segmentsToTrie :: ModuleName.Canonical -> [N.Name] -> Opt.Main -> Trie
428segmentsToTrie home segments main =
429 case segments of
430 [] ->
431 Trie (Just (home, main)) Map.empty
433 segment : otherSegments ->
434 Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))
437merge :: Trie -> Trie -> Trie
438merge (Trie main1 subs1) (Trie main2 subs2) =
439 Trie
440 (checkedMerge main1 main2)
441 (Map.unionWith merge subs1 subs2)
444checkedMerge :: Maybe a -> Maybe a -> Maybe a
445checkedMerge a b =
446 case (a, b) of
447 (Nothing, main) ->
448 main
450 (main, Nothing) ->
451 main
453 (Just _, Just _) ->
454 error "cannot have two modules with the same name"