git.iko.soy/elk
on 375ed59 help sign in
elk/src/Generate/JavaScript.hs
190 lines 5.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript (generate) where
5import Control.Monad (foldM)
6import Data.Monoid ((<>))
7import qualified Data.List as List
8import qualified Data.Map as Map
9import qualified Data.Set as Set
10import qualified Data.Text as Text
11import qualified Data.Text.Encoding as Text
12import qualified Data.ByteString.Builder as BS
14import qualified AST.Effects as Effects
15import qualified AST.Expression.Optimized as Opt
16import qualified AST.Kernel as Kernel
17import qualified AST.Module.Name as ModuleName
18import qualified AST.Variable as Var
19import qualified Elm.Package as Pkg
20import qualified Elm.Compiler.Objects.Internal as Obj
21import qualified Generate.JavaScript.Builder as JsBuilder
22import qualified Generate.JavaScript.Effects as JsEffects
23import qualified Generate.JavaScript.Expression as JsExpr
24import qualified Generate.JavaScript.Variable as JS
28-- GENERATE JAVASCRIPT
31generate :: Bool -> Obj.Graph -> Obj.Roots -> BS.Builder
32generate debug graph roots =
33 let
34 (State builders _ _ effects _) =
35 List.foldl' (crawl graph) (initialState debug) (Obj.toGlobals roots)
37 managers =
38 JS.run (JsEffects.generate effects)
39 in
40 List.foldl' (\rest stmt -> stmt <> rest) managers builders
44-- CRAWL STATE
47data State =
48 State
49 { _builders :: [BS.Builder]
50 , _seenDecls :: Set.Set Var.Global
51 , _seenKernels :: Set.Set ModuleName.Raw
52 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
53 , _debug :: Bool
54 }
57initialState :: Bool -> State
58initialState debug =
59 State [] Set.empty Set.empty Map.empty debug
63-- CRAWL
66crawl :: Obj.Graph -> State -> Var.Global -> State
67crawl graph@(Obj.Graph decls kernels) state@(State _ seenDecls seenKernels _ _) name@(Var.Global home _) =
68 if Set.member name seenDecls then
69 state
71 else if home == virtualDomDebug then
72 state
74 else
75 case Map.lookup name decls of
76 Just decl ->
77 crawlDecl graph name decl state
79 Nothing ->
80 let
81 kernelModule =
82 ModuleName._module home
83 in
84 if Set.member kernelModule seenKernels then
85 state
86 else
87 case Map.lookup kernelModule kernels of
88 Just info ->
89 crawlKernel graph kernelModule info state
91 Nothing ->
92 error (crawlError name)
96-- CRAWL DECL
99crawlDecl :: Obj.Graph -> Var.Global -> Opt.Decl -> State -> State
100crawlDecl graph var@(Var.Global home name) (Opt.Decl direct indirect fx body) state1 =
101 let
102 state2 =
103 state1 { _seenDecls = Set.insert var (_seenDecls state1) }
105 (State builders seenDecls seenKernels effects debug) =
106 Set.foldl' (crawl graph) state2 direct
108 stmt =
109 JS.run (JsExpr.generateDecl home name body)
111 state4 =
112 State
113 { _builders = JsBuilder.stmtToBuilder stmt : builders
114 , _seenDecls = seenDecls
115 , _seenKernels = seenKernels
116 , _effects = maybe id (Map.insert home) fx effects
117 , _debug = debug
118 }
119 in
120 Set.foldl' (crawl graph) state4 indirect
124-- CRAWL KERNEL
127crawlKernel :: Obj.Graph -> ModuleName.Raw -> Kernel.Info -> State -> State
128crawlKernel graph name (Kernel.Info imports chunks) state1 =
129 let
130 state2 =
131 state1 { _seenKernels = Set.insert name (_seenKernels state1) }
133 (State builders seenDecls seenKernels effects debug) =
134 List.foldl' (crawl graph) state2 (map toCoreGlobal imports)
136 builder =
137 JS.run (foldM (chunkToBuilder debug) mempty chunks)
138 in
139 State
140 { _builders = builder : builders
141 , _seenDecls = seenDecls
142 , _seenKernels = seenKernels
143 , _effects = effects
144 , _debug = debug
145 }
148toCoreGlobal :: ( ModuleName.Raw, Text.Text ) -> Var.Global
149toCoreGlobal (home, name) =
150 Var.Global (ModuleName.inCore home) name
153chunkToBuilder :: Bool -> BS.Builder -> Kernel.Chunk -> JS.Generator BS.Builder
154chunkToBuilder debug builder chunk =
155 case chunk of
156 Kernel.JS javascript ->
157 return $ BS.byteString javascript <> builder
159 Kernel.Var home name ->
160 do expr <- JS.global (Var.Global (ModuleName.inCore home) name)
161 return $ JsBuilder.exprToBuilder expr <> builder
163 Kernel.Field name ->
164 -- TODO generate a smaller field
165 return $ Text.encodeUtf8Builder name <> builder
167 Kernel.Debug isDebug ->
168 -- TODO pick based on what compile mode we are in
169 if isDebug && debug then
170 return builder
171 else
172 return $ "_UNUSED" <> builder
176-- CRAWL HELPERS
179crawlError :: Var.Global -> String
180crawlError (Var.Global (ModuleName.Canonical pkg home) name) =
181 Text.unpack $
182 "compiler bug manifesting in Generate.JavaScript\n"
183 <> "Could not find " <> Pkg.toText pkg <> " " <> ModuleName.toText home <> "." <> name <> "\n"
184 <> "Please report at <https://github.com/elm-lang/elm-compiler/issues>\n"
185 <> "Try to make an <http://sscce.org/> that demonstrates the issue!"
188virtualDomDebug :: ModuleName.Canonical
189virtualDomDebug =
190 ModuleName.inVirtualDom "VirtualDom.Debug"