git.iko.soy/elk
on ca2be8a help sign in
elk/src/AST/Optimized.hs
414 lines 10 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module AST.Optimized
3 ( Def(..)
4 , Expr(..)
5 , Global(..)
6 , kernel
7 , Path(..)
8 , Destructor(..)
9 , Decider(..)
10 , Choice(..)
11 , Graph(..)
12 , Main(..)
13 , Node(..)
14 , EffectsType(..)
15 , KContent(..)
16 , KChunk(..)
17 )
18 where
21import Control.Monad (liftM, liftM2, liftM3, liftM4)
22import Data.Binary
23import qualified Data.ByteString as BS
24import qualified Data.Map as Map
25import qualified Data.Set as Set
26import Data.Text (Text)
28import qualified AST.Canonical as Can
29import qualified AST.Module.Name as ModuleName
30import qualified Data.Index as Index
31import qualified Elm.Name as N
32import qualified Elm.Package as Pkg
33import qualified Optimize.DecisionTree as DT
34import qualified Reporting.Region as R
38-- EXPRESSIONS
41data Expr
42 = Bool Bool
43 | Chr Text
44 | Str Text
45 | Int Int
46 | Float Double
47 | VarLocal N.Name
48 | VarGlobal Global
49 | VarEnum Global Index.ZeroBased
50 | VarBox Global
51 | VarCycle ModuleName.Canonical N.Name
52 | VarDebug N.Name ModuleName.Canonical R.Region (Maybe N.Name)
53 | VarKernel N.Name N.Name
54 | List [Expr]
55 | Function [N.Name] Expr
56 | Call Expr [Expr]
57 | TailCall N.Name [(N.Name, Expr)]
58 | If [(Expr, Expr)] Expr
59 | Let Def Expr
60 | Destruct Destructor Expr
61 | Case N.Name N.Name (Decider Choice) [(Int, Expr)]
62 | Accessor N.Name
63 | Access Expr N.Name
64 | Update Expr (Map.Map N.Name Expr)
65 | Record (Map.Map N.Name Expr)
66 | Unit
67 | Tuple Expr Expr (Maybe Expr)
68 | Shader Text
71data Global = Global ModuleName.Canonical N.Name
72 deriving (Eq, Ord)
75-- Provide "List" not "Elm.Kernel.List"
76--
77kernel :: N.Name -> Global
78kernel home =
79 Global (ModuleName.Canonical Pkg.kernel home) N.dollar
83-- DEFINITIONS
86data Def
87 = Def N.Name Expr
88 | TailDef N.Name [N.Name] Expr
91data Destructor =
92 Destructor N.Name Path
95data Path
96 = Index Index.ZeroBased Path
97 | Field N.Name Path
98 | Unbox Path
99 | Root N.Name
103-- BRANCHING
106data Decider a
107 = Leaf a
108 | Chain
109 { _testChain :: [(DT.Path, DT.Test)]
110 , _success :: Decider a
111 , _failure :: Decider a
112 }
113 | FanOut
114 { _path :: DT.Path
115 , _tests :: [(DT.Test, Decider a)]
116 , _fallback :: Decider a
117 }
118 deriving (Eq)
121data Choice
122 = Inline Expr
123 | Jump Int
127-- OBJECT GRAPH
130data Graph =
131 Graph
132 { _mains :: Map.Map ModuleName.Canonical Main
133 , _nodes :: Map.Map Global Node
134 , _fields :: Map.Map N.Name Int
135 }
138data Main
139 = Static
140 | Dynamic
141 { _message :: Can.Type
142 , _decoder :: Expr
143 }
146data Node
147 = Define Expr (Set.Set Global)
148 | DefineTailFunc [N.Name] Expr (Set.Set Global)
149 | Ctor N.Name Index.ZeroBased Int
150 | Enum N.Name Index.ZeroBased
151 | Box N.Name
152 | Link Global
153 | Cycle [(N.Name, Expr)] (Set.Set Global)
154 | Manager EffectsType
155 | Kernel KContent (Maybe KContent)
156 | PortIncoming Expr (Set.Set Global)
157 | PortOutgoing Expr (Set.Set Global)
160data EffectsType = Cmd | Sub | Fx
163data KContent =
164 KContent [KChunk] (Set.Set Global)
167data KChunk
168 = JS BS.ByteString
169 | ElmVar ModuleName.Canonical N.Name
170 | JsVar N.Name N.Name
171 | ElmField N.Name
172 | JsField Int
173 | JsEnum Int
174 | Debug
175 | Prod
179-- BINARY
182instance Binary Global where
183 get = liftM2 Global get get
184 put (Global a b) = put a >> put b
187instance Binary Expr where
188 put expr =
189 case expr of
190 Bool a -> putWord8 0 >> put a
191 Chr a -> putWord8 1 >> put a
192 Str a -> putWord8 2 >> put a
193 Int a -> putWord8 3 >> put a
194 Float a -> putWord8 4 >> put a
195 VarLocal a -> putWord8 5 >> put a
196 VarGlobal a -> putWord8 6 >> put a
197 VarEnum a b -> putWord8 7 >> put a >> put b
198 VarBox a -> putWord8 8 >> put a
199 VarCycle a b -> putWord8 9 >> put a >> put b
200 VarDebug a b c d -> putWord8 10 >> put a >> put b >> put c >> put d
201 VarKernel a b -> putWord8 11 >> put a >> put b
202 List a -> putWord8 12 >> put a
203 Function a b -> putWord8 13 >> put a >> put b
204 Call a b -> putWord8 14 >> put a >> put b
205 TailCall a b -> putWord8 15 >> put a >> put b
206 If a b -> putWord8 16 >> put a >> put b
207 Let a b -> putWord8 17 >> put a >> put b
208 Destruct a b -> putWord8 18 >> put a >> put b
209 Case a b c d -> putWord8 19 >> put a >> put b >> put c >> put d
210 Accessor a -> putWord8 20 >> put a
211 Access a b -> putWord8 21 >> put a >> put b
212 Update a b -> putWord8 22 >> put a >> put b
213 Record a -> putWord8 23 >> put a
214 Unit -> putWord8 24
215 Tuple a b c -> putWord8 25 >> put a >> put b >> put c
216 Shader a -> putWord8 26 >> put a
218 get =
219 do word <- getWord8
220 case word of
221 0 -> liftM Bool get
222 1 -> liftM Chr get
223 2 -> liftM Str get
224 3 -> liftM Int get
225 4 -> liftM Float get
226 5 -> liftM VarLocal get
227 6 -> liftM VarGlobal get
228 7 -> liftM2 VarEnum get get
229 8 -> liftM VarBox get
230 9 -> liftM2 VarCycle get get
231 10 -> liftM4 VarDebug get get get get
232 11 -> liftM2 VarKernel get get
233 12 -> liftM List get
234 13 -> liftM2 Function get get
235 14 -> liftM2 Call get get
236 15 -> liftM2 TailCall get get
237 16 -> liftM2 If get get
238 17 -> liftM2 Let get get
239 18 -> liftM2 Destruct get get
240 19 -> liftM4 Case get get get get
241 20 -> liftM Accessor get
242 21 -> liftM2 Access get get
243 22 -> liftM2 Update get get
244 23 -> liftM Record get
245 24 -> pure Unit
246 25 -> liftM3 Tuple get get get
247 26 -> liftM Shader get
248 _ -> error "problem getting Opt.Expr binary"
251instance Binary Def where
252 put def =
253 case def of
254 Def a b -> putWord8 0 >> put a >> put b
255 TailDef a b c -> putWord8 1 >> put a >> put b >> put c
257 get =
258 do word <- getWord8
259 case word of
260 0 -> liftM2 Def get get
261 1 -> liftM3 TailDef get get get
262 _ -> error "problem getting Opt.Def binary"
265instance Binary Destructor where
266 get = liftM2 Destructor get get
267 put (Destructor a b) = put a >> put b
270instance Binary Path where
271 put destructor =
272 case destructor of
273 Index a b -> putWord8 0 >> put a >> put b
274 Field a b -> putWord8 1 >> put a >> put b
275 Unbox a -> putWord8 2 >> put a
276 Root a -> putWord8 3 >> put a
278 get =
279 do word <- getWord8
280 case word of
281 0 -> liftM2 Index get get
282 1 -> liftM2 Field get get
283 2 -> liftM Unbox get
284 3 -> liftM Root get
285 _ -> error "problem getting Opt.Path binary"
288instance (Binary a) => Binary (Decider a) where
289 put decider =
290 case decider of
291 Leaf a -> putWord8 0 >> put a
292 Chain a b c -> putWord8 1 >> put a >> put b >> put c
293 FanOut a b c -> putWord8 2 >> put a >> put b >> put c
295 get =
296 do word <- getWord8
297 case word of
298 0 -> liftM Leaf get
299 1 -> liftM3 Chain get get get
300 2 -> liftM3 FanOut get get get
301 _ -> error "problem getting Opt.Decider binary"
304instance Binary Choice where
305 put choice =
306 case choice of
307 Inline expr -> putWord8 0 >> put expr
308 Jump index -> putWord8 1 >> put index
310 get =
311 do word <- getWord8
312 case word of
313 0 -> liftM Inline get
314 1 -> liftM Jump get
315 _ -> error "problem getting Opt.Choice binary"
319instance Binary Graph where
320 get = liftM3 Graph get get get
321 put (Graph a b c) = put a >> put b >> put c
324instance Binary Main where
325 put main =
326 case main of
327 Static -> putWord8 0
328 Dynamic a b -> putWord8 1 >> put a >> put b
330 get =
331 do word <- getWord8
332 case word of
333 0 -> return Static
334 1 -> liftM2 Dynamic get get
335 _ -> error "problem getting Opt.Main binary"
338instance Binary Node where
339 put node =
340 case node of
341 Define a b -> putWord8 0 >> put a >> put b
342 DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
343 Ctor a b c -> putWord8 2 >> put a >> put b >> put c
344 Enum a b -> putWord8 3 >> put a >> put b
345 Box a -> putWord8 4 >> put a
346 Link a -> putWord8 5 >> put a
347 Cycle a b -> putWord8 6 >> put a >> put b
348 Manager a -> putWord8 7 >> put a
349 Kernel a b -> putWord8 8 >> put a >> put b
350 PortIncoming a b -> putWord8 9 >> put a >> put b
351 PortOutgoing a b -> putWord8 10 >> put a >> put b
353 get =
354 do word <- getWord8
355 case word of
356 0 -> liftM2 Define get get
357 1 -> liftM3 DefineTailFunc get get get
358 2 -> liftM3 Ctor get get get
359 3 -> liftM2 Enum get get
360 4 -> liftM Box get
361 5 -> liftM Link get
362 6 -> liftM2 Cycle get get
363 7 -> liftM Manager get
364 8 -> liftM2 Kernel get get
365 9 -> liftM2 PortIncoming get get
366 10 -> liftM2 PortOutgoing get get
367 _ -> error "problem getting Opt.Node binary"
370instance Binary EffectsType where
371 put effectsType =
372 case effectsType of
373 Cmd -> putWord8 0
374 Sub -> putWord8 1
375 Fx -> putWord8 2
377 get =
378 do word <- getWord8
379 case word of
380 0 -> return Cmd
381 1 -> return Sub
382 2 -> return Fx
383 _ -> error "problem getting Opt.EffectsType binary"
386instance Binary KContent where
387 get = liftM2 KContent get get
388 put (KContent a b) = put a >> put b
391instance Binary KChunk where
392 put chunk =
393 case chunk of
394 JS a -> putWord8 0 >> put a
395 ElmVar a b -> putWord8 1 >> put a >> put b
396 JsVar a b -> putWord8 2 >> put a >> put b
397 ElmField a -> putWord8 3 >> put a
398 JsField a -> putWord8 4 >> put a
399 JsEnum a -> putWord8 5 >> put a
400 Debug -> putWord8 6
401 Prod -> putWord8 7
403 get =
404 do word <- getWord8
405 case word of
406 0 -> liftM JS get
407 1 -> liftM2 ElmVar get get
408 2 -> liftM2 JsVar get get
409 3 -> liftM ElmField get
410 4 -> liftM JsField get
411 5 -> liftM JsEnum get
412 6 -> return Debug
413 7 -> return Prod
414 _ -> error "problem deserializing AST.Optimized.KChunk"