git.iko.soy/elk
on 9fd8302 help sign in
elk/src/Generate/JavaScript.hs
163 lines 4.0 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 Data.Text (Text)
11import qualified Data.ByteString.Builder as BS
13import qualified AST.Effects as Effects
14import qualified AST.Expression.Optimized as Opt
15import qualified AST.Module.Name as ModuleName
16import qualified AST.Variable as Var
17import qualified Elm.Package as Pkg
18import qualified Elm.Compiler.Objects.Internal as Obj
19import qualified Generate.JavaScript.Builder as JS
20import qualified Generate.JavaScript.Expression as JS
21import qualified Generate.JavaScript.Helpers as JS
22import qualified Generate.JavaScript.Variable as JS
26-- GENERATE JAVASCRIPT
29generate :: Obj.Graph -> Obj.Roots -> (Set.Set ModuleName.Canonical, BS.Builder)
30generate (Obj.Graph graph) roots =
31 let
32 (State builders _ natives effects) =
33 List.foldl' (crawl graph) empty (Obj.toGlobals roots)
35 managers =
36 Map.foldrWithKey addManager "" effects
38 javascript =
39 List.foldl' (\rest js -> js <> rest) managers builders
40 in
41 (natives, javascript)
45-- DEAD CODE ELIMINATION
48data State =
49 State
50 { _js :: [BS.Builder]
51 , _seen :: Set.Set Var.Global
52 , _natives :: Set.Set ModuleName.Canonical
53 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
54 }
57empty :: State
58empty =
59 State [] Set.empty Set.empty Map.empty
63-- DEAD CODE ELIMINATION
66type Graph = Map.Map Var.Global Opt.Decl
69crawl :: Graph -> State -> Var.Global -> State
70crawl graph state@(State js seen natives effects) name@(Var.Global home _) =
71 if Set.member name seen then
72 state
74 else
75 case Map.lookup name graph of
76 Just decl ->
77 crawlDecl graph name decl state
79 Nothing ->
80 if ModuleName.canonicalIsNative home then
81 State js seen (Set.insert home natives) effects
82 else
83 error "TODO something went wrong"
86crawlDecl :: Graph -> Var.Global -> Opt.Decl -> State -> State
87crawlDecl graph name@(Var.Global home _) (Opt.Decl deps mfx body) state =
88 let
89 newState =
90 state { _seen = Set.insert name (_seen state) }
92 (State js seen natives effects) =
93 Set.foldl' (crawl graph) newState deps
95 newEffects =
96 case mfx of
97 Nothing -> effects
98 Just fx -> Map.insert home fx effects
99 in
100 State
101 { _js = generateDecl name body : js
102 , _seen = seen
103 , _natives = natives
104 , _effects = newEffects
105 }
108generateDecl :: Var.Global -> Opt.Def -> BS.Builder
109generateDecl (Var.Global home name) def =
110 let
111 genBody =
112 JS.generateDecl home name def
113 in
114 JS.encodeUtf8 (State.evalState genBody 0)
118-- ADD EFFECT MANAGER
121addManager :: ModuleName.Canonical -> Effects.ManagerType -> BS.Builder -> BS.Builder
122addManager name manager builder =
123 JS.encodeUtf8 [genManager name manager] <> builder
126genManager :: ModuleName.Canonical -> Effects.ManagerType -> JS.Stmt
127genManager moduleName@(ModuleName.Canonical pkg _) manager =
128 let
129 managers =
130 JS.coreNative "Platform" "effectManagers"
132 managerName =
133 JS.String (ModuleName.canonicalToText moduleName)
135 entry name =
136 ( JS.IdProp (JS.Id name)
137 , JS.ref (JS.qualified moduleName name)
138 )
140 managerEntries =
141 [ "pkg" ==> Pkg.toText pkg
142 , entry "init"
143 , entry "onEffects"
144 , entry "onSelfMsg"
145 ]
147 otherEntries =
148 case manager of
149 Effects.Cmds -> [ "tag" ==> "cmd", entry "cmdMap" ]
150 Effects.Subs -> [ "tag" ==> "sub", entry "subMap" ]
151 Effects.Both -> [ "tag" ==> "fx", entry "cmdMap", entry "subMap" ]
152 in
153 JS.ExprStmt $
154 JS.Assign
155 (JS.LBracket managers managerName)
156 (JS.Object (managerEntries ++ otherEntries))
159(==>) :: Text -> Text -> ( JS.Prop, JS.Expr )
160(==>) key value =
161 ( JS.IdProp (JS.Id key)
162 , JS.String value
163 )