git.iko.soy/elk
on bc755bb help sign in
elk/src/AST/Optimized.hs
411 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 = Chr Text
43 | Str Text
44 | Int Int
45 | Float Double
46 | VarLocal N.Name
47 | VarGlobal Global
48 | VarEnum Global Index.ZeroBased
49 | VarBox Global
50 | VarCycle ModuleName.Canonical N.Name
51 | VarDebug N.Name ModuleName.Canonical R.Region (Maybe N.Name)
52 | VarKernel N.Name N.Name
53 | List [Expr]
54 | Function [N.Name] Expr
55 | Call Expr [Expr]
56 | TailCall N.Name [(N.Name, Expr)]
57 | If [(Expr, Expr)] Expr
58 | Let Def Expr
59 | Destruct Destructor Expr
60 | Case N.Name N.Name (Decider Choice) [(Int, Expr)]
61 | Accessor N.Name
62 | Access Expr N.Name
63 | Update Expr (Map.Map N.Name Expr)
64 | Record (Map.Map N.Name Expr)
65 | Unit
66 | Tuple Expr Expr (Maybe Expr)
67 | Shader Text
70data Global = Global ModuleName.Canonical N.Name
71 deriving (Eq, Ord)
74-- Provide "List" not "Elm.Kernel.List"
75--
76kernel :: N.Name -> Global
77kernel home =
78 Global (ModuleName.Canonical Pkg.kernel home) N.dollar
82-- DEFINITIONS
85data Def
86 = Def N.Name Expr
87 | TailDef N.Name [N.Name] Expr
90data Destructor =
91 Destructor N.Name Path
94data Path
95 = Index Index.ZeroBased Path
96 | Field N.Name Path
97 | Unbox Path
98 | Root N.Name
102-- BRANCHING
105data Decider a
106 = Leaf a
107 | Chain
108 { _testChain :: [(DT.Path, DT.Test)]
109 , _success :: Decider a
110 , _failure :: Decider a
111 }
112 | FanOut
113 { _path :: DT.Path
114 , _tests :: [(DT.Test, Decider a)]
115 , _fallback :: Decider a
116 }
117 deriving (Eq)
120data Choice
121 = Inline Expr
122 | Jump Int
126-- OBJECT GRAPH
129data Graph =
130 Graph
131 { _mains :: Map.Map ModuleName.Canonical Main
132 , _nodes :: Map.Map Global Node
133 , _fields :: Map.Map N.Name Int
134 }
137data Main
138 = Static
139 | Dynamic
140 { _decoder :: Expr
141 , _message :: Can.Type
142 }
145data Node
146 = Define Expr (Set.Set Global)
147 | DefineTailFunc [N.Name] Expr (Set.Set Global)
148 | Ctor N.Name Index.ZeroBased Int
149 | Enum N.Name Index.ZeroBased
150 | Box N.Name
151 | Link Global
152 | Cycle [(N.Name, Expr)] (Set.Set Global)
153 | Manager EffectsType
154 | Kernel KContent (Maybe KContent)
155 | PortIncoming Expr (Set.Set Global)
156 | PortOutgoing Expr (Set.Set Global)
159data EffectsType = Cmd | Sub | Fx
162data KContent =
163 KContent [KChunk] (Set.Set Global)
166data KChunk
167 = JS BS.ByteString
168 | ElmVar ModuleName.Canonical N.Name
169 | JsVar N.Name N.Name
170 | ElmField N.Name
171 | JsField Int
172 | JsEnum Int
173 | Debug
174 | Prod
178-- BINARY
181instance Binary Global where
182 get = liftM2 Global get get
183 put (Global a b) = put a >> put b
186instance Binary Expr where
187 put expr =
188 case expr of
189 Chr a -> putWord8 0 >> put a
190 Str a -> putWord8 1 >> put a
191 Int a -> putWord8 2 >> put a
192 Float a -> putWord8 3 >> put a
193 VarLocal a -> putWord8 4 >> put a
194 VarGlobal a -> putWord8 5 >> put a
195 VarEnum a b -> putWord8 6 >> put a >> put b
196 VarBox a -> putWord8 7 >> put a
197 VarCycle a b -> putWord8 8 >> put a >> put b
198 VarDebug a b c d -> putWord8 9 >> put a >> put b >> put c >> put d
199 VarKernel a b -> putWord8 10 >> put a >> put b
200 List a -> putWord8 11 >> put a
201 Function a b -> putWord8 12 >> put a >> put b
202 Call a b -> putWord8 13 >> put a >> put b
203 TailCall a b -> putWord8 14 >> put a >> put b
204 If a b -> putWord8 15 >> put a >> put b
205 Let a b -> putWord8 16 >> put a >> put b
206 Destruct a b -> putWord8 17 >> put a >> put b
207 Case a b c d -> putWord8 18 >> put a >> put b >> put c >> put d
208 Accessor a -> putWord8 19 >> put a
209 Access a b -> putWord8 20 >> put a >> put b
210 Update a b -> putWord8 21 >> put a >> put b
211 Record a -> putWord8 22 >> put a
212 Unit -> putWord8 23
213 Tuple a b c -> putWord8 24 >> put a >> put b >> put c
214 Shader a -> putWord8 25 >> put a
216 get =
217 do word <- getWord8
218 case word of
219 0 -> liftM Chr get
220 1 -> liftM Str get
221 2 -> liftM Int get
222 3 -> liftM Float get
223 4 -> liftM VarLocal get
224 5 -> liftM VarGlobal get
225 6 -> liftM2 VarEnum get get
226 7 -> liftM VarBox get
227 8 -> liftM2 VarCycle get get
228 9 -> liftM4 VarDebug get get get get
229 10 -> liftM2 VarKernel get get
230 11 -> liftM List get
231 12 -> liftM2 Function get get
232 13 -> liftM2 Call get get
233 14 -> liftM2 TailCall get get
234 15 -> liftM2 If get get
235 16 -> liftM2 Let get get
236 17 -> liftM2 Destruct get get
237 18 -> liftM4 Case get get get get
238 19 -> liftM Accessor get
239 20 -> liftM2 Access get get
240 21 -> liftM2 Update get get
241 22 -> liftM Record get
242 23 -> pure Unit
243 24 -> liftM3 Tuple get get get
244 25 -> liftM Shader get
245 _ -> error "problem getting Opt.Expr binary"
248instance Binary Def where
249 put def =
250 case def of
251 Def a b -> putWord8 0 >> put a >> put b
252 TailDef a b c -> putWord8 1 >> put a >> put b >> put c
254 get =
255 do word <- getWord8
256 case word of
257 0 -> liftM2 Def get get
258 1 -> liftM3 TailDef get get get
259 _ -> error "problem getting Opt.Def binary"
262instance Binary Destructor where
263 get = liftM2 Destructor get get
264 put (Destructor a b) = put a >> put b
267instance Binary Path where
268 put destructor =
269 case destructor of
270 Index a b -> putWord8 0 >> put a >> put b
271 Field a b -> putWord8 1 >> put a >> put b
272 Unbox a -> putWord8 2 >> put a
273 Root a -> putWord8 3 >> put a
275 get =
276 do word <- getWord8
277 case word of
278 0 -> liftM2 Index get get
279 1 -> liftM2 Field get get
280 2 -> liftM Unbox get
281 3 -> liftM Root get
282 _ -> error "problem getting Opt.Path binary"
285instance (Binary a) => Binary (Decider a) where
286 put decider =
287 case decider of
288 Leaf a -> putWord8 0 >> put a
289 Chain a b c -> putWord8 1 >> put a >> put b >> put c
290 FanOut a b c -> putWord8 2 >> put a >> put b >> put c
292 get =
293 do word <- getWord8
294 case word of
295 0 -> liftM Leaf get
296 1 -> liftM3 Chain get get get
297 2 -> liftM3 FanOut get get get
298 _ -> error "problem getting Opt.Decider binary"
301instance Binary Choice where
302 put choice =
303 case choice of
304 Inline expr -> putWord8 0 >> put expr
305 Jump index -> putWord8 1 >> put index
307 get =
308 do word <- getWord8
309 case word of
310 0 -> liftM Inline get
311 1 -> liftM Jump get
312 _ -> error "problem getting Opt.Choice binary"
316instance Binary Graph where
317 get = liftM3 Graph get get get
318 put (Graph a b c) = put a >> put b >> put c
321instance Binary Main where
322 put main =
323 case main of
324 Static -> putWord8 0
325 Dynamic a b -> putWord8 1 >> put a >> put b
327 get =
328 do word <- getWord8
329 case word of
330 0 -> return Static
331 1 -> liftM2 Dynamic get get
332 _ -> error "problem getting Opt.Main binary"
335instance Binary Node where
336 put node =
337 case node of
338 Define a b -> putWord8 0 >> put a >> put b
339 DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
340 Ctor a b c -> putWord8 2 >> put a >> put b >> put c
341 Enum a b -> putWord8 3 >> put a >> put b
342 Box a -> putWord8 4 >> put a
343 Link a -> putWord8 5 >> put a
344 Cycle a b -> putWord8 6 >> put a >> put b
345 Manager a -> putWord8 7 >> put a
346 Kernel a b -> putWord8 8 >> put a >> put b
347 PortIncoming a b -> putWord8 9 >> put a >> put b
348 PortOutgoing a b -> putWord8 10 >> put a >> put b
350 get =
351 do word <- getWord8
352 case word of
353 0 -> liftM2 Define get get
354 1 -> liftM3 DefineTailFunc get get get
355 2 -> liftM3 Ctor get get get
356 3 -> liftM2 Enum get get
357 4 -> liftM Box get
358 5 -> liftM Link get
359 6 -> liftM2 Cycle get get
360 7 -> liftM Manager get
361 8 -> liftM2 Kernel get get
362 9 -> liftM2 PortIncoming get get
363 10 -> liftM2 PortOutgoing get get
364 _ -> error "problem getting Opt.Node binary"
367instance Binary EffectsType where
368 put effectsType =
369 case effectsType of
370 Cmd -> putWord8 0
371 Sub -> putWord8 1
372 Fx -> putWord8 2
374 get =
375 do word <- getWord8
376 case word of
377 0 -> return Cmd
378 1 -> return Sub
379 2 -> return Fx
380 _ -> error "problem getting Opt.EffectsType binary"
383instance Binary KContent where
384 get = liftM2 KContent get get
385 put (KContent a b) = put a >> put b
388instance Binary KChunk where
389 put chunk =
390 case chunk of
391 JS a -> putWord8 0 >> put a
392 ElmVar a b -> putWord8 1 >> put a >> put b
393 JsVar a b -> putWord8 2 >> put a >> put b
394 ElmField a -> putWord8 3 >> put a
395 JsField a -> putWord8 4 >> put a
396 JsEnum a -> putWord8 5 >> put a
397 Debug -> putWord8 6
398 Prod -> putWord8 7
400 get =
401 do word <- getWord8
402 case word of
403 0 -> liftM JS get
404 1 -> liftM2 ElmVar get get
405 2 -> liftM2 JsVar get get
406 3 -> liftM ElmField get
407 4 -> liftM JsField get
408 5 -> liftM JsEnum get
409 6 -> return Debug
410 7 -> return Prod
411 _ -> error "problem deserializing AST.Optimized.KChunk"