git.iko.soy/elk
on 2277745 help sign in
elk/src/Generate/JavaScript.hs
363 lines 9.3 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 Elm.Package as Pkg
23import qualified Generate.JavaScript.Builder as JS
24import qualified Generate.JavaScript.Expression as Expr
25import qualified Generate.JavaScript.Name as Name
29-- GENERATE
32data Mode = Debug | Prod
35data Roots
36 = Mains [ModuleName.Canonical]
37 | Value ModuleName.Canonical N.Name
40generate :: Mode -> Name.Target -> Opt.Graph -> Roots -> Either [ModuleName.Canonical] B.Builder
41generate mode target (Opt.Graph mains nodes fields) roots =
42 case roots of
43 Value home name ->
44 Right $ stateToBuilder $
45 addGlobal (toRealMode mode target fields) nodes emptyState (Opt.Global home name)
47 Mains modules ->
48 generateMain (toRealMode mode target fields) nodes
49 <$> verifyMains mains modules
52toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode
53toRealMode mode target fields =
54 case mode of
55 Debug ->
56 Name.Debug target
58 Prod ->
59 Name.Prod target (Name.shortenFieldNames fields)
63-- GRAPH TRAVERSAL STATE
66data State =
67 State
68 { _revBuilders :: [B.Builder]
69 , _seenGlobals :: Set.Set Opt.Global
70 }
73emptyState :: State
74emptyState =
75 State [] Set.empty
78stateToBuilder :: State -> B.Builder
79stateToBuilder (State revBuilders _) =
80 List.foldl1' (\builder b -> b <> builder) revBuilders
84-- ADD DEPENDENCIES
87type Graph = Map.Map Opt.Global Opt.Node
90addGlobal :: Name.Mode -> Graph -> State -> Opt.Global -> State
91addGlobal mode graph state@(State builders seen) global =
92 if Set.member global seen then
93 state
94 else
95 addGlobalHelp mode graph global $
96 State builders (Set.insert global seen)
99addGlobalHelp :: Name.Mode -> Graph -> Opt.Global -> State -> State
100addGlobalHelp mode graph global state =
101 let
102 addDeps deps someState =
103 Set.foldl' (addGlobal mode graph) someState deps
104 in
105 case graph ! global of
106 Opt.Define expr deps ->
107 addStmt (addDeps deps state) (
108 var global (Expr.generate mode expr)
109 )
111 Opt.DefineTailFunc argNames body deps ->
112 addStmt (addDeps deps state) (
113 var global (Expr.generateFunction (map Name.fromLocal argNames) (Expr.generate mode body))
114 )
116 Opt.Ctor name index arity ->
117 let (args, ctor) = Expr.generateCtor mode name index arity in
118 addStmt state (
119 var global (Expr.generateFunction args ctor)
120 )
122 Opt.Link linkedGlobal ->
123 addGlobal mode graph state linkedGlobal
125 Opt.Cycle cycle deps ->
126 addStmt (addDeps deps state) (
127 generateCycle mode global cycle
128 )
130 Opt.Manager effectsType ->
131 generateManager mode graph global effectsType state
133 Opt.Kernel clientChunks clientDeps maybeServer ->
134 case maybeServer of
135 Just (serverChunks, serverDeps) | Name.isServer mode ->
136 addBuilder (addDeps serverDeps state) (generateKernel mode serverChunks)
138 _ ->
139 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)
141 Opt.PortIncoming decoder deps ->
142 addStmt (addDeps deps state) (
143 generatePort mode global "incomingPort" decoder
144 )
146 Opt.PortOutgoing encoder deps ->
147 addStmt (addDeps deps state) (
148 generatePort mode global "outgoingPort" encoder
149 )
152addStmt :: State -> JS.Stmt -> State
153addStmt state stmt =
154 addBuilder state (JS.stmtToBuilder stmt)
157addBuilder :: State -> B.Builder -> State
158addBuilder (State revBuilders seen) builder =
159 State (builder:revBuilders) seen
162var :: Opt.Global -> Expr.Code -> JS.Stmt
163var (Opt.Global home name) code =
164 JS.Var [ (Name.fromGlobal home name, Just (Expr.codeToExpr code)) ]
168-- GENERATE CYCLES
171generateCycle :: Name.Mode -> Opt.Global -> [(N.Name, Opt.Expr)] -> JS.Stmt
172generateCycle mode (Opt.Global home _) cycle =
173 let
174 safeDefs = map (generateSafeCycle mode home) cycle
175 realDefs = map (generateRealCycle home) cycle
176 -- TODO add `try` in debug mode nice infinite recursion reports
177 in
178 JS.Block (safeDefs ++ realDefs)
181generateSafeCycle :: Name.Mode -> ModuleName.Canonical -> (N.Name, Opt.Expr) -> JS.Stmt
182generateSafeCycle mode home (name, expr) =
183 JS.FunctionStmt (Name.fromCycle home name) [] $
184 Expr.codeToStmtList (Expr.generate mode expr)
187generateRealCycle :: ModuleName.Canonical -> (N.Name, expr) -> JS.Stmt
188generateRealCycle home (name, _) =
189 let
190 safeName = Name.fromCycle home name
191 realName = Name.fromGlobal home name
192 in
193 JS.Block
194 [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
195 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
196 JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
197 ]
201-- GENERATE KERNEL
204generateKernel :: Name.Mode -> [Opt.KChunk] -> B.Builder
205generateKernel mode chunks =
206 List.foldl' (addChunk mode) mempty chunks
209addChunk :: Name.Mode -> B.Builder -> Opt.KChunk -> B.Builder
210addChunk mode builder chunk =
211 case chunk of
212 Opt.JS javascript ->
213 B.byteString javascript <> builder
215 Opt.Var home name ->
216 Name.toBuilder (Name.fromGlobal (ModuleName.Canonical Pkg.core home) name) <> builder
218 Opt.ElmField name ->
219 Name.toBuilder (Name.fromField mode name) <> builder
221 Opt.JsField int ->
222 Name.toBuilder (Name.fromInt int) <> builder
224 Opt.Enum int ->
225 Name.toBuilder (Name.fromInt int) <> builder
227 Opt.Debug ->
228 case mode of
229 Name.Debug _ ->
230 builder
232 Name.Prod _ _ ->
233 "_UNUSED" <> builder
235 Opt.Prod ->
236 case mode of
237 Name.Debug _ ->
238 "_UNUSED" <> builder
240 Name.Prod _ _ ->
241 builder
245-- GENERATE PORTS
248generatePort :: Name.Mode -> Opt.Global -> N.Name -> Opt.Expr -> JS.Stmt
249generatePort mode (Opt.Global home name) makePort converter =
250 let
251 definition =
252 JS.Call (JS.Ref (Name.fromKernel N.platform makePort))
253 [ JS.String (N.toBuilder name)
254 , Expr.codeToExpr (Expr.generate mode converter)
255 ]
256 in
257 JS.Var [ (Name.fromGlobal home name, Just definition) ]
261-- GENERATE MANAGER
265generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State
266generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =
267 let
268 managerLVar =
269 JS.LBracket
270 (JS.Ref (Name.fromKernel N.platform "effectManagers"))
271 (JS.String (N.toBuilder moduleName))
273 (deps, args, stmts) =
274 generateManagerHelp home effectsType
276 createManager =
277 JS.ExprStmt $ JS.Assign managerLVar $
278 JS.Call (JS.Ref (Name.fromKernel N.platform "createManager")) args
279 in
280 addStmt (List.foldl' (addGlobal mode graph) state deps) $
281 JS.Block (createManager : stmts)
284generateLeaf :: ModuleName.Canonical -> N.Name -> JS.Stmt
285generateLeaf home@(ModuleName.Canonical _ moduleName) name =
286 let
287 definition =
288 JS.Call leaf [ JS.String (N.toBuilder moduleName) ]
289 in
290 JS.Var [ (Name.fromGlobal home name, Just definition) ]
293{-# NOINLINE leaf #-}
294leaf :: JS.Expr
295leaf =
296 JS.Ref (Name.fromKernel N.platform "leaf")
299generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])
300generateManagerHelp home effectsType =
301 let
302 dep name = Opt.Global home name
303 ref name = JS.Ref (Name.fromGlobal home name)
304 in
305 case effectsType of
306 Opt.Cmd ->
307 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]
308 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]
309 , [ generateLeaf home "command" ]
310 )
312 Opt.Sub ->
313 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]
314 , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]
315 , [ generateLeaf home "subscription" ]
316 )
318 Opt.Fx ->
319 ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]
320 , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]
321 , [ generateLeaf home "command"
322 , generateLeaf home "subscription"
323 ]
324 )
328-- ADD MAIN
331type Mains =
332 Map.Map ModuleName.Canonical Opt.Main
335generateMain :: Name.Mode -> Graph -> Mains -> B.Builder
336generateMain mode graph mains =
337 mconcat
338 [ stateToBuilder $ Map.foldrWithKey (addMain mode graph) emptyState mains
339 , exportMains mains
340 ]
343addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
344addMain mode graph home _ state =
345 addGlobal mode graph state (Opt.Global home "main")
348exportMains :: Mains -> B.Builder
349exportMains mains =
350 error "TODO" mains
353verifyMains :: Mains -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] Mains
354verifyMains mains modules =
355 let
356 rootSet = Set.fromList modules
357 rootMap = Map.restrictKeys mains rootSet
358 in
359 if Map.size rootMap == Set.size rootSet then
360 Right rootMap
361 else
362 Left $ Set.toList $
363 Set.intersection rootSet (Map.keysSet mains)