git.iko.soy/elk
on 70f3f60 help sign in
elk/src/Generate/JavaScript.hs
174 lines 4.6 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.ByteString.Builder as BS
13import qualified AST.Effects as Effects
14import qualified AST.Expression.Optimized as Opt
15import qualified AST.Kernel as Kernel
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 JsBuilder
21import qualified Generate.JavaScript.Effects as JsEffects
22import qualified Generate.JavaScript.Expression as JsExpr
23import qualified Generate.JavaScript.Variable as JS
27-- GENERATE JAVASCRIPT
30generate :: Obj.Graph -> Obj.Roots -> BS.Builder
31generate graph roots =
32 let
33 (State builders _ _ effects) =
34 List.foldl' (crawl graph) initialState (Obj.toGlobals roots)
36 managers =
37 JS.run (JsEffects.generate effects)
38 in
39 List.foldl' (\rest stmt -> stmt <> rest) managers builders
43-- CRAWL STATE
46data State =
47 State
48 { _builders :: [BS.Builder]
49 , _seenDecls :: Set.Set Var.Global
50 , _seenKernels :: Set.Set ModuleName.Raw
51 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
52 }
55initialState :: State
56initialState =
57 State [] Set.empty Set.empty Map.empty
61-- CRAWL
64crawl :: Obj.Graph -> State -> Var.Global -> State
65crawl graph@(Obj.Graph decls kernels) state@(State _ seenDecls seenKernels _) name@(Var.Global home _) =
66 if Set.member name seenDecls then
67 state
69 else if home == virtualDomDebug then
70 state
72 else
73 case Map.lookup name decls of
74 Just decl ->
75 crawlDecl graph name decl state
77 Nothing ->
78 let
79 kernelModule =
80 ModuleName._module home
81 in
82 if Set.member kernelModule seenKernels then
83 state
84 else
85 case Map.lookup kernelModule kernels of
86 Just info ->
87 crawlKernel graph kernelModule info state
89 Nothing ->
90 error (crawlError name)
94-- CRAWL DECL
97crawlDecl :: Obj.Graph -> Var.Global -> Opt.Decl -> State -> State
98crawlDecl graph var@(Var.Global home name) (Opt.Decl direct indirect fx body) state1 =
99 let
100 state2 =
101 state1 { _seenDecls = Set.insert var (_seenDecls state1) }
103 (State builders seenDecls seenKernels effects) =
104 Set.foldl' (crawl graph) state2 direct
106 stmt =
107 JS.run (JsExpr.generateDecl home name body)
109 state4 =
110 State
111 { _builders = JsBuilder.stmtToBuilder stmt : builders
112 , _seenDecls = seenDecls
113 , _seenKernels = seenKernels
114 , _effects = maybe id (Map.insert home) fx effects
115 }
116 in
117 Set.foldl' (crawl graph) state4 indirect
121-- CRAWL KERNEL
124crawlKernel :: Obj.Graph -> ModuleName.Raw -> Kernel.Info -> State -> State
125crawlKernel graph name (Kernel.Info imports chunks) state1 =
126 let
127 state2 =
128 state1 { _seenKernels = Set.insert name (_seenKernels state1) }
130 (State builders seenDecls seenKernels effects) =
131 List.foldl' (crawl graph) state2 (map toCoreGlobal imports)
133 builder =
134 JS.run (foldM chunkToBuilder mempty chunks)
135 in
136 State
137 { _builders = builder : builders
138 , _seenDecls = seenDecls
139 , _seenKernels = seenKernels
140 , _effects = effects
141 }
144toCoreGlobal :: ( ModuleName.Raw, Text.Text ) -> Var.Global
145toCoreGlobal (home, name) =
146 Var.Global (ModuleName.inCore home) name
149chunkToBuilder :: BS.Builder -> Kernel.Chunk -> JS.Generator BS.Builder
150chunkToBuilder builder chunk =
151 case chunk of
152 Kernel.JS javascript ->
153 return $ BS.byteString javascript <> builder
155 Kernel.Var home name ->
156 do expr <- JS.global (Var.Global (ModuleName.inCore home) name)
157 return $ JsBuilder.exprToBuilder expr <> builder
160-- CRAWL HELPERS
163crawlError :: Var.Global -> String
164crawlError (Var.Global (ModuleName.Canonical pkg home) name) =
165 Text.unpack $
166 "compiler bug manifesting in Generate.JavaScript\n"
167 <> "Could not find " <> Pkg.toText pkg <> " " <> ModuleName.toText home <> "." <> name <> "\n"
168 <> "Please report at <https://github.com/elm-lang/elm-compiler/issues>\n"
169 <> "Try to make an <http://sscce.org/> that demonstrates the issue!"
172virtualDomDebug :: ModuleName.Canonical
173virtualDomDebug =
174 ModuleName.inVirtualDom "VirtualDom.Debug"