git.iko.soy/elk
on e28d01e help sign in
elk/src/Generate/JavaScript.hs
218 lines 5.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript
4 ( generate
5 , Target(..)
6 )
7 where
9import Control.Monad (foldM)
10import Data.Monoid ((<>))
11import qualified Data.List as List
12import qualified Data.Map as Map
13import qualified Data.Set as Set
14import qualified Data.Text as Text
15import qualified Data.Text.Encoding as Text
16import qualified Data.ByteString.Builder as BS
18import qualified AST.Effects as Effects
19import qualified AST.Expression.Optimized as Opt
20import qualified AST.Kernel as Kernel
21import qualified AST.Module.Name as ModuleName
22import qualified AST.Variable as Var
23import qualified Elm.Package as Pkg
24import qualified Elm.Compiler.Objects.Internal as Obj
25import qualified Generate.JavaScript.Builder as JsBuilder
26import qualified Generate.JavaScript.Effects as JsEffects
27import qualified Generate.JavaScript.Expression as JsExpr
28import qualified Generate.JavaScript.Variable as JS
32-- GENERATE JAVASCRIPT
35generate :: Bool -> Target -> Obj.Graph -> Obj.Roots -> BS.Builder
36generate debug target graph roots =
37 let
38 (State builders _ _ effects) =
39 List.foldl' (crawl (Env debug target) graph) initialState (Obj.toGlobals roots)
41 managers =
42 JS.run (JsEffects.generate effects)
43 in
44 List.foldl' (\rest stmt -> stmt <> rest) managers builders
48-- CRAWL ENV
51data Env =
52 Env
53 { _debug :: Bool
54 , _target :: Target
55 }
58data Target = Client | Server
62-- CRAWL STATE
65data State =
66 State
67 { _builders :: [BS.Builder]
68 , _seenDecls :: Set.Set Var.Global
69 , _seenKernels :: Set.Set ModuleName.Raw
70 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
71 }
74initialState :: State
75initialState =
76 State [] Set.empty Set.empty Map.empty
80-- CRAWL
83crawl :: Env -> Obj.Graph -> State -> Var.Global -> State
84crawl env graph@(Obj.Graph decls kernels) state@(State _ seenDecls seenKernels _) name@(Var.Global home _) =
85 if Set.member name seenDecls then
86 state
88 else if home == virtualDomDebug then
89 state
91 else
92 case Map.lookup name decls of
93 Just decl ->
94 crawlDecl env graph name decl state
96 Nothing ->
97 let
98 kernelModule =
99 ModuleName._module home
100 in
101 if Set.member kernelModule seenKernels then
102 state
103 else
104 case Map.lookup kernelModule kernels of
105 Just info ->
106 crawlKernel env graph kernelModule info state
108 Nothing ->
109 error (crawlError name)
113-- CRAWL DECL
116crawlDecl :: Env -> Obj.Graph -> Var.Global -> Opt.Decl -> State -> State
117crawlDecl env graph var@(Var.Global home name) (Opt.Decl direct indirect fx body) state1 =
118 let
119 state2 =
120 state1 { _seenDecls = Set.insert var (_seenDecls state1) }
122 (State builders seenDecls seenKernels effects) =
123 Set.foldl' (crawl env graph) state2 direct
125 stmt =
126 JS.run (JsExpr.generateDecl home name body)
128 state4 =
129 State
130 { _builders = JsBuilder.stmtToBuilder stmt : builders
131 , _seenDecls = seenDecls
132 , _seenKernels = seenKernels
133 , _effects = maybe id (Map.insert home) fx effects
134 }
135 in
136 Set.foldl' (crawl env graph) state4 indirect
140-- CRAWL KERNEL
143crawlKernel :: Env -> Obj.Graph -> ModuleName.Raw -> Kernel.Data -> State -> State
144crawlKernel env@(Env _ target) graph name (Kernel.Data client maybeServer) state =
145 let
146 content =
147 case target of
148 Server ->
149 maybe client id maybeServer
151 Client ->
152 client
153 in
154 crawlKernelContent env graph name content state
157crawlKernelContent :: Env -> Obj.Graph -> ModuleName.Raw -> Kernel.Content -> State -> State
158crawlKernelContent env@(Env debug _) graph name (Kernel.Content imports chunks) state1 =
159 let
160 state2 =
161 state1 { _seenKernels = Set.insert name (_seenKernels state1) }
163 (State builders seenDecls seenKernels effects) =
164 List.foldl' (crawl env graph) state2 (map toCoreGlobal imports)
166 builder =
167 JS.run (foldM (chunkToBuilder debug) mempty chunks)
168 in
169 State
170 { _builders = builder : builders
171 , _seenDecls = seenDecls
172 , _seenKernels = seenKernels
173 , _effects = effects
174 }
177toCoreGlobal :: ( ModuleName.Raw, Text.Text ) -> Var.Global
178toCoreGlobal (home, name) =
179 Var.Global (ModuleName.inCore home) name
182chunkToBuilder :: Bool -> BS.Builder -> Kernel.Chunk -> JS.Generator BS.Builder
183chunkToBuilder debug builder chunk =
184 case chunk of
185 Kernel.JS javascript ->
186 return $ BS.byteString javascript <> builder
188 Kernel.Var home name ->
189 do expr <- JS.global (Var.Global (ModuleName.inCore home) name)
190 return $ JsBuilder.exprToBuilder expr <> builder
192 Kernel.Field name ->
193 -- TODO generate a smaller field
194 return $ Text.encodeUtf8Builder name <> builder
196 Kernel.Debug ->
197 return $ if debug then builder else "_UNUSED" <> builder
199 Kernel.Prod ->
200 return $ if debug then "_UNUSED" <> builder else builder
204-- CRAWL HELPERS
207crawlError :: Var.Global -> String
208crawlError (Var.Global (ModuleName.Canonical pkg home) name) =
209 Text.unpack $
210 "compiler bug manifesting in Generate.JavaScript\n"
211 <> "Could not find " <> Pkg.toText pkg <> " " <> ModuleName.toText home <> "." <> name <> "\n"
212 <> "Please report at <https://github.com/elm-lang/elm-compiler/issues>\n"
213 <> "Try to make an <http://sscce.org/> that demonstrates the issue!"
216virtualDomDebug :: ModuleName.Canonical
217virtualDomDebug =
218 ModuleName.inVirtualDom "VirtualDom.Debug"