git.iko.soy/elk
on 474ec0d help sign in
elk/src/Generate/JavaScript.hs
365 lines 9.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript
4 ( Mode(..)
5 , Roots(..)
6 , generate
7 )
8 where
11import Prelude hiding (cycle)
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
19import qualified AST.Optimized as Opt
20import qualified AST.Module.Name as ModuleName
21import qualified Elm.Name as N
22import qualified Generate.JavaScript.Builder as JS
23import qualified Generate.JavaScript.Expression as Expr
24import qualified Generate.JavaScript.Name as Name
28-- GENERATE
31data Mode = Debug | Prod
34data Roots
35 = Mains [ModuleName.Canonical]
36 | Value ModuleName.Canonical N.Name
39generate :: Mode -> Name.Target -> Opt.Graph -> Roots -> Either [ModuleName.Canonical] B.Builder
40generate mode target (Opt.Graph mains nodes fields) roots =
41 case roots of
42 Value home name ->
43 Right $ stateToBuilder $
44 addGlobal (toRealMode mode target fields) nodes emptyState (Opt.Global home name)
46 Mains modules ->
47 generateMain (toRealMode mode target fields) nodes
48 <$> verifyMains mains modules
51toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
52toRealMode mode target fields =
53 case mode of
54 Debug ->
55 Name.Debug target
57 Prod ->
58 Name.Prod target (Name.shortenFieldNames fields)
62-- GRAPH TRAVERSAL STATE
65data State =
66 State
67 { _revBuilders :: [B.Builder]
68 , _seenGlobals :: Set.Set Opt.Global
69 }
72emptyState :: State
73emptyState =
74 State [] Set.empty
77stateToBuilder :: State -> B.Builder
78stateToBuilder (State revBuilders _) =
79 List.foldl1' (\builder b -> b <> builder) revBuilders
83-- ADD DEPENDENCIES
86type Graph = Map.Map Opt.Global Opt.Node
89addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
90addGlobal mode graph state@(State builders seen) global =
91 if Set.member global seen then
92 state
93 else
94 addGlobalHelp mode graph global $
95 State builders (Set.insert global seen)
98addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
99addGlobalHelp mode graph global state =
100 let
101 addDeps deps someState =
102 Set.foldl' (addGlobal mode graph) someState deps
103 in
104 case graph ! global of
105 Opt.Define expr deps ->
106 addStmt (addDeps deps state) (
107 var global (Expr.generate mode expr)
108 )
110 Opt.DefineTailFunc argNames body deps ->
111 addStmt (addDeps deps state) (
112 var global (Expr.generateFunction (map Name.fromLocal argNames) (Expr.generate mode body))
113 )
115 Opt.Ctor name index arity ->
116 let (args, ctor) = Expr.generateCtor mode name index arity in
117 addStmt state (
118 var global (Expr.generateFunction args ctor)
119 )
121 Opt.Link linkedGlobal ->
122 addGlobal mode graph state linkedGlobal
124 Opt.Cycle cycle deps ->
125 addStmt (addDeps deps state) (
126 generateCycle mode global cycle
127 )
129 Opt.Manager effectsType ->
130 generateManager mode graph global effectsType state
132 Opt.Kernel (Opt.KContent clientChunks clientDeps) maybeServer ->
133 case maybeServer of
134 Just (Opt.KContent serverChunks serverDeps) | Name.isServer mode ->
135 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
137 _ ->
138 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
140 Opt.PortIncoming decoder deps ->
141 addStmt (addDeps deps state) (
142 generatePort mode global "incomingPort" decoder
143 )
145 Opt.PortOutgoing encoder deps ->
146 addStmt (addDeps deps state) (
147 generatePort mode global "outgoingPort" encoder
148 )
151addStmt :: State -> JS.Stmt -> State
152addStmt state stmt =
153 addBuilder state (JS.stmtToBuilder stmt)
156addBuilder :: State -> B.Builder -> State
157addBuilder (State revBuilders seen) builder =
158 State (builder:revBuilders) seen
161var :: Opt.Global -> Expr.Code -> JS.Stmt
162var (Opt.Global home name) code =
163 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
167-- GENERATE CYCLES
170generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
171generateCycle mode (Opt.Global home _) cycle =
172 let
173 safeDefs = map (generateSafeCycle mode home) cycle
174 realDefs = map (generateRealCycle home) cycle
175 -- TODO add `try` in debug mode nice infinite recursion reports
176 in
177 JS.Block (safeDefs ++ realDefs)
180generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
181generateSafeCycle mode home (name, expr) =
182 JS.FunctionStmt (Name.fromCycle home name) [] $
183 Expr.codeToStmtList (Expr.generate mode expr)
186generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
187generateRealCycle home (name, _) =
188 let
189 safeName = Name.fromCycle home name
190 realName = Name.fromGlobal home name
191 in
192 JS.Block
193 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
194 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
195 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
196 ]
200-- GENERATE KERNEL
203generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
204generateKernel mode chunks =
205 List.foldl' (addChunk mode) mempty chunks
208addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
209addChunk mode builder chunk =
210 case chunk of
211 Opt.JS javascript ->
212 B.byteString javascript <> builder
214 Opt.ElmVar home name ->
215 Name.toBuilder (Name.fromGlobal home name) <> builder
217 Opt.JsVar home name ->
218 Name.toBuilder (Name.fromKernel home name) <> builder
220 Opt.ElmField name ->
221 Name.toBuilder (Name.fromField mode name) <> builder
223 Opt.JsField int ->
224 Name.toBuilder (Name.fromInt int) <> builder
226 Opt.Enum int ->
227 Name.toBuilder (Name.fromInt int) <> builder
229 Opt.Debug ->
230 case mode of
231 Name.Debug _ ->
232 builder
234 Name.Prod _ _ ->
235 "_UNUSED" <> builder
237 Opt.Prod ->
238 case mode of
239 Name.Debug _ ->
240 "_UNUSED" <> builder
242 Name.Prod _ _ ->
243 builder
247-- GENERATE PORTS
250generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
251generatePort mode (Opt.Global home name) makePort converter =
252 let
253 definition =
254 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
255 [ JS.String (N.toBuilder name)
256 , Expr.codeToExpr (Expr.generate mode converter)
257 ]
258 in
259 JS.Var [ (Name.fromGlobal home name, Just definition) ]
263-- GENERATE MANAGER
267generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
268generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
269 let
270 managerLVar =
271 JS.LBracket
272 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
273 (JS.String (N.toBuilder moduleName))
275 (deps, args, stmts) =
276 generateManagerHelp home effectsType
278 createManager =
279 JS.ExprStmt $ JS.Assign managerLVar $
280 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
281 in
282 addStmt (List.foldl' (addGlobal mode graph) state deps) $
283 JS.Block (createManager : stmts)
286generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
287generateLeaf home@(ModuleName.Canonical _ moduleName) name =
288 let
289 definition =
290 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
291 in
292 JS.Var [ (Name.fromGlobal home name, Just definition) ]
295{-# NOINLINE leaf #-}
296leaf :: JS.Expr
297leaf =
298 JS.Ref (Name.fromKernel N.platform "leaf")
301generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
302generateManagerHelp home effectsType =
303 let
304 dep name = Opt.Global home name
305 ref name = JS.Ref (Name.fromGlobal home name)
306 in
307 case effectsType of
308 Opt.Cmd ->
309 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
310 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
311 , [ generateLeaf home "command" ]
312 )
314 Opt.Sub ->
315 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
316 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
317 , [ generateLeaf home "subscription" ]
318 )
320 Opt.Fx ->
321 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
322 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
323 , [ generateLeaf home "command"
324 , generateLeaf home "subscription"
325 ]
326 )
330-- ADD MAIN
333type Mains =
334 Map.Map ModuleName.Canonical Opt.Main
337generateMain :: Name.Mode -> Graph -> Mains -> B.Builder
338generateMain mode graph mains =
339 mconcat
340 [ stateToBuilder $ Map.foldrWithKey (addMain mode graph) emptyState mains
341 , exportMains mains
342 ]
345addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
346addMain mode graph home _ state =
347 addGlobal mode graph state (Opt.Global home "main")
350exportMains :: Mains -> B.Builder
351exportMains mains =
352 error "TODO" mains
355verifyMains :: Mains -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] Mains
356verifyMains mains modules =
357 let
358 rootSet = Set.fromList modules
359 rootMap = Map.restrictKeys mains rootSet
360 in
361 if Map.size rootMap == Set.size rootSet then
362 Right rootMap
363 else
364 Left $ Set.toList $
365 Set.intersection rootSet (Map.keysSet mains)