git.iko.soy/elk
on 247359c help sign in
elk/src/Generate/JavaScript.hs
427 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript
4 ( ReplBuilder(..)
5 , generateForRepl
6 , Mode(..)
7 , MainsBuilder(..)
8 , MainTrie(..)
9 , generateMains
10 )
11 where
14import Prelude hiding (cycle)
15import qualified Data.ByteString.Builder as B
16import Data.Monoid ((<>))
17import qualified Data.List as List
18import Data.Map ((!))
19import qualified Data.Map as Map
20import qualified Data.Set as Set
21import qualified Data.Text as Text
23import qualified AST.Optimized as Opt
24import qualified AST.Module.Name as ModuleName
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 FOR REPL
36data ReplBuilder =
37 ReplBuilder
38 { _repl_code :: B.Builder
39 , _repl_name :: B.Builder
40 }
43generateForRepl :: Opt.Graph -> ModuleName.Canonical -> N.Name -> ReplBuilder
44generateForRepl (Opt.Graph _ graph _) home name =
45 ReplBuilder
46 { _repl_code =
47 stateToBuilder $
48 addGlobal (Name.Debug Name.Client) graph emptyState (Opt.Global home name)
49 , _repl_name =
50 Name.toBuilder (Name.fromGlobal home name)
51 }
55-- GENERATE MAINS
58data MainsBuilder =
59 MainsBuilder
60 { _main_code :: B.Builder
61 , _main_trie :: MainTrie
62 }
65data Mode = Debug | Prod
68generateMains :: Mode -> Name.Target -> Opt.Graph -> I.Interfaces -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] MainsBuilder
69generateMains mode target (Opt.Graph mains graph fields) interfaces roots =
70 let
71 rootSet = Set.fromList roots
72 rootMap = Map.restrictKeys mains rootSet
73 in
74 if Map.size rootMap == Set.size rootSet then
75 let
76 realMode = toRealMode mode target fields
77 state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap
78 in
79 Right $ MainsBuilder (stateToBuilder state) (toMainTrie realMode interfaces rootMap)
81 else
82 Left $ Set.toList $
83 Set.intersection rootSet (Map.keysSet mains)
86addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
87addMain mode graph home _ state =
88 addGlobal mode graph state (Opt.Global home "main")
91toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
92toRealMode mode target fields =
93 case mode of
94 Debug ->
95 Name.Debug target
97 Prod ->
98 Name.Prod target (Name.shortenFieldNames fields)
102-- GRAPH TRAVERSAL STATE
105data State =
106 State
107 { _revBuilders :: [B.Builder]
108 , _seenGlobals :: Set.Set Opt.Global
109 }
112emptyState :: State
113emptyState =
114 State [] Set.empty
117stateToBuilder :: State -> B.Builder
118stateToBuilder (State revBuilders _) =
119 List.foldl1' (\builder b -> b <> builder) revBuilders
123-- ADD DEPENDENCIES
126type Graph = Map.Map Opt.Global Opt.Node
129addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
130addGlobal mode graph state@(State builders seen) global =
131 if Set.member global seen then
132 state
133 else
134 addGlobalHelp mode graph global $
135 State builders (Set.insert global seen)
138addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
139addGlobalHelp mode graph global state =
140 let
141 addDeps deps someState =
142 Set.foldl' (addGlobal mode graph) someState deps
143 in
144 case graph ! global of
145 Opt.Define expr deps ->
146 addStmt (addDeps deps state) (
147 var global (Expr.generate mode expr)
148 )
150 Opt.DefineTailFunc argNames body deps ->
151 addStmt (addDeps deps state) (
152 var global (Expr.generateFunction (map Name.fromLocal argNames) (Expr.generate mode body))
153 )
155 Opt.Ctor name index arity ->
156 let (args, ctor) = Expr.generateCtor mode name index arity in
157 addStmt state (
158 var global (Expr.generateFunction args ctor)
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.PortIncoming decoder deps ->
181 addStmt (addDeps deps state) (
182 generatePort mode global "incomingPort" decoder
183 )
185 Opt.PortOutgoing encoder deps ->
186 addStmt (addDeps deps state) (
187 generatePort mode global "outgoingPort" encoder
188 )
191addStmt :: State -> JS.Stmt -> State
192addStmt state stmt =
193 addBuilder state (JS.stmtToBuilder stmt)
196addBuilder :: State -> B.Builder -> State
197addBuilder (State revBuilders seen) builder =
198 State (builder:revBuilders) seen
201var :: Opt.Global -> Expr.Code -> JS.Stmt
202var (Opt.Global home name) code =
203 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
207-- GENERATE CYCLES
210generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
211generateCycle mode (Opt.Global home _) cycle =
212 let
213 safeDefs = map (generateSafeCycle mode home) cycle
214 realDefs = map (generateRealCycle home) cycle
215 -- TODO add `try` in debug mode nice infinite recursion reports
216 in
217 JS.Block (safeDefs ++ realDefs)
220generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
221generateSafeCycle mode home (name, expr) =
222 JS.FunctionStmt (Name.fromCycle home name) [] $
223 Expr.codeToStmtList (Expr.generate mode expr)
226generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
227generateRealCycle home (name, _) =
228 let
229 safeName = Name.fromCycle home name
230 realName = Name.fromGlobal home name
231 in
232 JS.Block
233 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
234 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
235 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
236 ]
240-- GENERATE KERNEL
243generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
244generateKernel mode chunks =
245 List.foldl' (addChunk mode) mempty chunks
248addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
249addChunk mode builder chunk =
250 case chunk of
251 Opt.JS javascript ->
252 B.byteString javascript <> builder
254 Opt.ElmVar home name ->
255 Name.toBuilder (Name.fromGlobal home name) <> builder
257 Opt.JsVar home name ->
258 Name.toBuilder (Name.fromKernel home name) <> builder
260 Opt.ElmField name ->
261 Name.toBuilder (Name.fromField mode name) <> builder
263 Opt.JsField int ->
264 Name.toBuilder (Name.fromInt int) <> builder
266 Opt.Enum int ->
267 Name.toBuilder (Name.fromInt int) <> builder
269 Opt.Debug ->
270 case mode of
271 Name.Debug _ ->
272 builder
274 Name.Prod _ _ ->
275 "_UNUSED" <> builder
277 Opt.Prod ->
278 case mode of
279 Name.Debug _ ->
280 "_UNUSED" <> builder
282 Name.Prod _ _ ->
283 builder
287-- GENERATE PORTS
290generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
291generatePort mode (Opt.Global home name) makePort converter =
292 let
293 definition =
294 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
295 [ JS.String (N.toBuilder name)
296 , Expr.codeToExpr (Expr.generate mode converter)
297 ]
298 in
299 JS.Var [ (Name.fromGlobal home name, Just definition) ]
303-- GENERATE MANAGER
307generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
308generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
309 let
310 managerLVar =
311 JS.LBracket
312 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
313 (JS.String (N.toBuilder moduleName))
315 (deps, args, stmts) =
316 generateManagerHelp home effectsType
318 createManager =
319 JS.ExprStmt $ JS.Assign managerLVar $
320 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
321 in
322 addStmt (List.foldl' (addGlobal mode graph) state deps) $
323 JS.Block (createManager : stmts)
326generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
327generateLeaf home@(ModuleName.Canonical _ moduleName) name =
328 let
329 definition =
330 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
331 in
332 JS.Var [ (Name.fromGlobal home name, Just definition) ]
335{-# NOINLINE leaf #-}
336leaf :: JS.Expr
337leaf =
338 JS.Ref (Name.fromKernel N.platform "leaf")
341generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
342generateManagerHelp home effectsType =
343 let
344 dep name = Opt.Global home name
345 ref name = JS.Ref (Name.fromGlobal home name)
346 in
347 case effectsType of
348 Opt.Cmd ->
349 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
350 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
351 , [ generateLeaf home "command" ]
352 )
354 Opt.Sub ->
355 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
356 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
357 , [ generateLeaf home "subscription" ]
358 )
360 Opt.Fx ->
361 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
362 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
363 , [ generateLeaf home "command"
364 , generateLeaf home "subscription"
365 ]
366 )
370-- MAIN TRIE
373data MainTrie =
374 MainTrie
375 { _main :: Maybe B.Builder
376 , _subs :: Map.Map N.Name MainTrie
377 }
380emptyTrie :: MainTrie
381emptyTrie =
382 MainTrie Nothing Map.empty
385toMainTrie :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> MainTrie
386toMainTrie mode interfaces mains =
387 Map.foldrWithKey (addMainTrie mode interfaces) emptyTrie mains
390addMainTrie :: Name.Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> MainTrie -> MainTrie
391addMainTrie mode interfaces home@(ModuleName.Canonical _ moduleName) main trie =
392 let
393 segments = Text.splitOn "." moduleName
394 initMain = Expr.generateMain mode interfaces home segments main
395 newTrie = segmentsToTrie segments (JS.exprToBuilder initMain)
396 in
397 merge trie newTrie
400segmentsToTrie :: [N.Name] -> B.Builder -> MainTrie
401segmentsToTrie segments mainBuilder =
402 case segments of
403 [] ->
404 MainTrie (Just mainBuilder) Map.empty
406 segment : otherSegments ->
407 MainTrie Nothing (Map.singleton segment (segmentsToTrie otherSegments mainBuilder))
410merge :: MainTrie -> MainTrie -> MainTrie
411merge (MainTrie main1 subs1) (MainTrie main2 subs2) =
412 MainTrie
413 (checkedMerge main1 main2)
414 (Map.unionWith merge subs1 subs2)
417checkedMerge :: Maybe a -> Maybe a -> Maybe a
418checkedMerge a b =
419 case (a, b) of
420 (Nothing, main) ->
421 main
423 (main, Nothing) ->
424 main
426 (Just _, Just _) ->
427 error "cannot have two modules with the same name"