git.iko.soy/elk
on 219aff8 help sign in
elk/src/Generate/JavaScript.hs
181 lines 4.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript (generate) where
5import qualified Control.Monad.State as State
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 Data.Text (Text)
12import qualified Data.ByteString.Builder as BS
14import qualified AST.Effects as Effects
15import qualified AST.Expression.Optimized as Opt
16import qualified AST.Module.Name as ModuleName
17import qualified AST.Variable as Var
18import qualified Elm.Package as Pkg
19import qualified Elm.Compiler.Objects.Internal as Obj
20import qualified Generate.JavaScript.Builder as JS
21import qualified Generate.JavaScript.Expression as JS
22import qualified Generate.JavaScript.Helpers as JS
23import qualified Generate.JavaScript.Variable as JS
27-- GENERATE JAVASCRIPT
30generate :: Obj.Graph -> Obj.Roots -> (Set.Set ModuleName.Canonical, BS.Builder)
31generate (Obj.Graph graph) roots =
32 let
33 (State builders _ natives effects) =
34 List.foldl' (crawl graph) empty (Obj.toGlobals roots)
36 managers =
37 Map.foldrWithKey addManager "" effects
39 javascript =
40 List.foldl' (\rest js -> js <> rest) managers builders
41 in
42 (natives, javascript)
46-- DEAD CODE ELIMINATION
49data State =
50 State
51 { _js :: [BS.Builder]
52 , _seen :: Set.Set Var.Global
53 , _natives :: Set.Set ModuleName.Canonical
54 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
55 }
58empty :: State
59empty =
60 State [] Set.empty Set.empty Map.empty
64-- DEAD CODE ELIMINATION
67type Graph = Map.Map Var.Global Opt.Decl
70crawl :: Graph -> State -> Var.Global -> State
71crawl graph state@(State js seen natives effects) name@(Var.Global home _) =
72 if Set.member name seen then
73 state
75 else if home == virtualDomDebug then
76 state
78 else
79 case Map.lookup name graph of
80 Just decl ->
81 crawlDecl graph name decl state
83 Nothing ->
84 if ModuleName.canonicalIsNative home then
85 State js seen (Set.insert home natives) effects
86 else
87 error (crawlError name)
90virtualDomDebug :: ModuleName.Canonical
91virtualDomDebug =
92 ModuleName.inVirtualDom "VirtualDom.Debug"
95crawlDecl :: Graph -> Var.Global -> Opt.Decl -> State -> State
96crawlDecl graph name@(Var.Global home _) (Opt.Decl deps mfx body) state =
97 let
98 newState =
99 state { _seen = Set.insert name (_seen state) }
101 (State js seen natives effects) =
102 Set.foldl' (crawl graph) newState deps
104 newEffects =
105 case mfx of
106 Nothing -> effects
107 Just fx -> Map.insert home fx effects
108 in
109 State
110 { _js = generateDecl name body : js
111 , _seen = seen
112 , _natives = natives
113 , _effects = newEffects
114 }
117crawlError :: Var.Global -> String
118crawlError (Var.Global (ModuleName.Canonical pkg home) name) =
119 Text.unpack $
120 "compiler bug manifesting in Generate.JavaScript\n"
121 <> "could not find " <> Pkg.toText pkg <> " " <> ModuleName.toText home <> "." <> name <> "\n"
122 <> "please report at <https://github.com/elm-lang/elm-compiler/issues>\n"
123 <> "try to make an <http://sscce.org/> that demonstrates the issue!"
126generateDecl :: Var.Global -> Opt.Def -> BS.Builder
127generateDecl (Var.Global home name) def =
128 let
129 genBody =
130 JS.generateDecl home name def
131 in
132 JS.encodeUtf8 (State.evalState genBody 0)
136-- ADD EFFECT MANAGER
139addManager :: ModuleName.Canonical -> Effects.ManagerType -> BS.Builder -> BS.Builder
140addManager name manager builder =
141 JS.encodeUtf8 [genManager name manager] <> builder
144genManager :: ModuleName.Canonical -> Effects.ManagerType -> JS.Stmt
145genManager moduleName@(ModuleName.Canonical pkg _) manager =
146 let
147 managers =
148 JS.coreNative "Platform" "effectManagers"
150 managerName =
151 JS.String (ModuleName.canonicalToText moduleName)
153 entry name =
154 ( JS.IdProp (JS.Id name)
155 , JS.ref (JS.qualified moduleName name)
156 )
158 managerEntries =
159 [ "pkg" ==> Pkg.toText pkg
160 , entry "init"
161 , entry "onEffects"
162 , entry "onSelfMsg"
163 ]
165 otherEntries =
166 case manager of
167 Effects.Cmds -> [ "tag" ==> "cmd", entry "cmdMap" ]
168 Effects.Subs -> [ "tag" ==> "sub", entry "subMap" ]
169 Effects.Both -> [ "tag" ==> "fx", entry "cmdMap", entry "subMap" ]
170 in
171 JS.ExprStmt $
172 JS.Assign
173 (JS.LBracket managers managerName)
174 (JS.Object (managerEntries ++ otherEntries))
177(==>) :: Text -> Text -> ( JS.Prop, JS.Expr )
178(==>) key value =
179 ( JS.IdProp (JS.Id key)
180 , JS.String value
181 )