git.iko.soy/elk
on f41abda help sign in
elk/src/Generate/JavaScript.hs
358 lines 9.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript
4 ( generate
5 , Roots(..)
6 )
7 where
10import Prelude hiding (cycle)
11import qualified Data.ByteString.Builder as B
12import Data.Monoid ((<>))
13import qualified Data.List as List
14import Data.Map ((!))
15import qualified Data.Map as Map
16import qualified Data.Set as Set
18import qualified AST.Optimized as Opt
19import qualified AST.Module.Name as ModuleName
20import qualified Elm.Name as N
21import qualified Elm.Package as Pkg
22import qualified Generate.JavaScript.Builder as JS
23import qualified Generate.JavaScript.Expression as Expr
24import qualified Generate.JavaScript.Name as Name
28-- GENERATE
31data Roots
32 = Mains [ModuleName.Canonical]
33 | Value ModuleName.Canonical N.Name
36generate :: Bool -> Name.Target -> Opt.Graph -> Roots -> Either [ModuleName.Canonical] B.Builder
37generate debug target (Opt.Graph mains nodes fields) roots =
38 case roots of
39 Value home name ->
40 Right $ stateToBuilder $
41 addGlobal (toMode debug target fields) nodes emptyState (Opt.Global home name)
43 Mains modules ->
44 generateMain (toMode debug target fields) nodes
45 <$> verifyMains mains modules
48toMode :: Bool -> Name.Target -> Map.Map N.Name Int -> Name.Mode
49toMode debug target fields =
50 if debug then
51 Name.Debug target
52 else
53 Name.Prod target (Name.shortenFieldNames fields)
57-- GRAPH TRAVERSAL STATE
60data State =
61 State
62 { _revBuilders :: [B.Builder]
63 , _seenGlobals :: Set.Set Opt.Global
64 }
67emptyState :: State
68emptyState =
69 State [] Set.empty
72stateToBuilder :: State -> B.Builder
73stateToBuilder (State revBuilders _) =
74 List.foldl1' (\builder b -> b <> builder) revBuilders
78-- ADD DEPENDENCIES
81type Mode = Name.Mode
82type Graph = Map.Map Opt.Global Opt.Node
85addGlobal :: Mode -> Graph -> State -> Opt.Global -> State
86addGlobal mode graph state@(State builders seen) global =
87 if Set.member global seen then
88 state
89 else
90 addGlobalHelp mode graph global $
91 State builders (Set.insert global seen)
94addGlobalHelp :: Mode -> Graph -> Opt.Global -> State -> State
95addGlobalHelp mode graph global state =
96 let
97 addDeps deps someState =
98 Set.foldl' (addGlobal mode graph) someState deps
99 in
100 case graph ! global of
101 Opt.Define expr deps ->
102 addStmt (addDeps deps state) (
103 var global (Expr.generate mode expr)
104 )
106 Opt.DefineTailFunc argNames body deps ->
107 addStmt (addDeps deps state) (
108 var global (Expr.generateFunction (map Name.fromLocal argNames) (Expr.generate mode body))
109 )
111 Opt.Ctor name index arity ->
112 let (args, ctor) = Expr.generateCtor mode name index arity in
113 addStmt state (
114 var global (Expr.generateFunction args ctor)
115 )
117 Opt.Link linkedGlobal ->
118 addGlobal mode graph state linkedGlobal
120 Opt.Cycle cycle deps ->
121 addStmt (addDeps deps state) (
122 generateCycle mode global cycle
123 )
125 Opt.Manager effectsType ->
126 generateManager mode graph global effectsType state
128 Opt.Kernel clientChunks clientDeps maybeServer ->
129 case maybeServer of
130 Just (serverChunks, serverDeps) | Name.isServer mode ->
131 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
133 _ ->
134 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
136 Opt.PortIncoming decoder deps ->
137 addStmt (addDeps deps state) (
138 generatePort mode global "incomingPort" decoder
139 )
141 Opt.PortOutgoing encoder deps ->
142 addStmt (addDeps deps state) (
143 generatePort mode global "outgoingPort" encoder
144 )
147addStmt :: State -> JS.Stmt -> State
148addStmt state stmt =
149 addBuilder state (JS.stmtToBuilder stmt)
152addBuilder :: State -> B.Builder -> State
153addBuilder (State revBuilders seen) builder =
154 State (builder:revBuilders) seen
157var :: Opt.Global -> Expr.Code -> JS.Stmt
158var (Opt.Global home name) code =
159 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
163-- GENERATE CYCLES
166generateCycle :: Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
167generateCycle mode (Opt.Global home _) cycle =
168 let
169 safeDefs = map (generateSafeCycle mode home) cycle
170 realDefs = map (generateRealCycle home) cycle
171 -- TODO add `try` in debug mode nice infinite recursion reports
172 in
173 JS.Block (safeDefs ++ realDefs)
176generateSafeCycle :: Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
177generateSafeCycle mode home (name, expr) =
178 JS.FunctionStmt (Name.fromCycle home name) [] $
179 Expr.codeToStmtList (Expr.generate mode expr)
182generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
183generateRealCycle home (name, _) =
184 let
185 safeName = Name.fromCycle home name
186 realName = Name.fromGlobal home name
187 in
188 JS.Block
189 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
190 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
191 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
192 ]
196-- GENERATE KERNEL
199generateKernel :: Mode -> [Opt.KChunk] -> B.Builder
200generateKernel mode chunks =
201 List.foldl' (addChunk mode) mempty chunks
204addChunk :: Mode -> B.Builder -> Opt.KChunk -> B.Builder
205addChunk mode builder chunk =
206 case chunk of
207 Opt.JS javascript ->
208 B.byteString javascript <> builder
210 Opt.Var home name ->
211 Name.toBuilder (Name.fromGlobal (ModuleName.Canonical Pkg.core home) name) <> builder
213 Opt.ElmField name ->
214 Name.toBuilder (Name.fromField mode name) <> builder
216 Opt.JsField int ->
217 Name.toBuilder (Name.fromInt int) <> builder
219 Opt.Enum int ->
220 Name.toBuilder (Name.fromInt int) <> builder
222 Opt.Debug ->
223 case mode of
224 Name.Debug _ ->
225 builder
227 Name.Prod _ _ ->
228 "_UNUSED" <> builder
230 Opt.Prod ->
231 case mode of
232 Name.Debug _ ->
233 "_UNUSED" <> builder
235 Name.Prod _ _ ->
236 builder
240-- GENERATE PORTS
243generatePort :: Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
244generatePort mode (Opt.Global home name) makePort converter =
245 let
246 definition =
247 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
248 [ JS.String (N.toBuilder name)
249 , Expr.codeToExpr (Expr.generate mode converter)
250 ]
251 in
252 JS.Var [ (Name.fromGlobal home name, Just definition) ]
256-- GENERATE MANAGER
260generateManager :: Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
261generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
262 let
263 managerLVar =
264 JS.LBracket
265 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
266 (JS.String (N.toBuilder moduleName))
268 (deps, args, stmts) =
269 generateManagerHelp home effectsType
271 createManager =
272 JS.ExprStmt $ JS.Assign managerLVar $
273 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
274 in
275 addStmt (List.foldl' (addGlobal mode graph) state deps) $
276 JS.Block (createManager : stmts)
279generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
280generateLeaf home@(ModuleName.Canonical _ moduleName) name =
281 let
282 definition =
283 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
284 in
285 JS.Var [ (Name.fromGlobal home name, Just definition) ]
288{-# NOINLINE leaf #-}
289leaf :: JS.Expr
290leaf =
291 JS.Ref (Name.fromKernel N.platform "leaf")
294generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
295generateManagerHelp home effectsType =
296 let
297 dep name = Opt.Global home name
298 ref name = JS.Ref (Name.fromGlobal home name)
299 in
300 case effectsType of
301 Opt.Cmd ->
302 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
303 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
304 , [ generateLeaf home "command" ]
305 )
307 Opt.Sub ->
308 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
309 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
310 , [ generateLeaf home "subscription" ]
311 )
313 Opt.Fx ->
314 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
315 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
316 , [ generateLeaf home "command"
317 , generateLeaf home "subscription"
318 ]
319 )
323-- ADD MAIN
326type Mains =
327 Map.Map ModuleName.Canonical Opt.Main
330generateMain :: Mode -> Graph -> Mains -> B.Builder
331generateMain mode graph mains =
332 mconcat
333 [ stateToBuilder $ Map.foldrWithKey (addMain mode graph) emptyState mains
334 , exportMains mains
335 ]
338addMain :: Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
339addMain mode graph home _ state =
340 addGlobal mode graph state (Opt.Global home "main")
343exportMains :: Mains -> B.Builder
344exportMains mains =
345 error "TODO" mains
348verifyMains :: Mains -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] Mains
349verifyMains mains modules =
350 let
351 rootSet = Set.fromList modules
352 rootMap = Map.restrictKeys mains rootSet
353 in
354 if Map.size rootMap == Set.size rootSet then
355 Right rootMap
356 else
357 Left $ Set.toList $
358 Set.intersection rootSet (Map.keysSet mains)