git.iko.soy/elk
on f232da4 help sign in
elk/src/Generate/JavaScript.hs
163 lines 3.9 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 Generate.JavaScript.Builder as JS
19import qualified Generate.JavaScript.Expression as JS
20import qualified Generate.JavaScript.Helpers as JS
21import qualified Generate.JavaScript.Variable as JS
25-- GENERATE JAVASCRIPT
28type Graph =
29 Map.Map Var.Global Opt.Decl
32generate :: Graph -> [Var.Global] -> (Set.Set ModuleName.Canonical, BS.Builder)
33generate graph roots =
34 let
35 (State builders _ natives effects) =
36 List.foldl' (crawl graph) empty roots
38 managers =
39 Map.foldrWithKey addManager "" effects
41 javascript =
42 List.foldl' (\rest js -> js <> rest) managers builders
43 in
44 (natives, javascript)
48-- DEAD CODE ELIMINATION
51data State =
52 State
53 { _js :: [BS.Builder]
54 , _seen :: Set.Set Var.Global
55 , _natives :: Set.Set ModuleName.Canonical
56 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
57 }
60empty :: State
61empty =
62 State [] Set.empty Set.empty Map.empty
66-- DEAD CODE ELIMINATION
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.generateDef (Just 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 )