git.iko.soy/elk
on 2deedfb help sign in
elk/src/AST/Optimized.hs
363 lines 9.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module AST.Optimized
3 ( Def(..)
4 , Expr(..)
5 , Global(..)
6 , kernel
7 , Decider(..)
8 , Choice(..)
9 , Graph(..)
10 , Main(..)
11 , Node(..)
12 , EffectsType(..)
13 , KContent(..)
14 , KChunk(..)
15 )
16 where
19import Control.Monad (liftM, liftM2, liftM3, liftM4)
20import Data.Binary
21import qualified Data.ByteString as BS
22import qualified Data.Map as Map
23import qualified Data.Set as Set
24import Data.Text (Text)
26import qualified AST.Canonical as Can
27import qualified AST.Module.Name as ModuleName
28import qualified Data.Index as Index
29import qualified Elm.Name as N
30import qualified Elm.Package as Pkg
31import qualified Optimize.DecisionTree as DT
32import qualified Reporting.Region as R
36-- EXPRESSIONS
39data Expr
40 = Chr Text
41 | Str Text
42 | Int Int
43 | Float Double
44 | VarLocal N.Name
45 | VarGlobal Global
46 | VarCycle ModuleName.Canonical N.Name
47 | VarDebug N.Name ModuleName.Canonical R.Region (Maybe N.Name)
48 | VarKernel N.Name N.Name
49 | List [Expr]
50 | Function [N.Name] Expr
51 | Call Expr [Expr]
52 | TailCall N.Name [(N.Name, Expr)]
53 | If [(Expr, Expr)] Expr
54 | Let Def Expr
55 | Case N.Name N.Name (Decider Choice) [(Int, Expr)]
56 | Index Expr Int
57 | Accessor N.Name
58 | Access Expr N.Name
59 | Update Expr (Map.Map N.Name Expr)
60 | Record (Map.Map N.Name Expr)
61 | Unit
62 | Tuple Expr Expr (Maybe Expr)
63 | Shader Text
66data Global = Global ModuleName.Canonical N.Name
67 deriving (Eq, Ord)
70-- Provide "List" not "Elm.Kernel.List"
71--
72kernel :: N.Name -> Global
73kernel home =
74 Global (ModuleName.Canonical Pkg.kernel home) N.dollar
78-- DEFINITIONS
81data Def
82 = Def N.Name Expr
83 | TailDef N.Name [N.Name] Expr
87-- BRANCHING
90data Decider a
91 = Leaf a
92 | Chain
93 { _testChain :: [(DT.Path, DT.Test)]
94 , _success :: Decider a
95 , _failure :: Decider a
96 }
97 | FanOut
98 { _path :: DT.Path
99 , _tests :: [(DT.Test, Decider a)]
100 , _fallback :: Decider a
101 }
102 deriving (Eq)
105data Choice
106 = Inline Expr
107 | Jump Int
111-- OBJECT GRAPH
114data Graph =
115 Graph
116 { _mains :: Map.Map ModuleName.Canonical Main
117 , _nodes :: Map.Map Global Node
118 , _fields :: Map.Map N.Name Int
119 }
122data Main
123 = Static
124 | Dynamic
125 { _decoder :: Expr
126 , _message :: Can.Type
127 }
130data Node
131 = Define Expr (Set.Set Global)
132 | DefineTailFunc [N.Name] Expr (Set.Set Global)
133 | Ctor N.Name Index.ZeroBased Int
134 | Link Global
135 | Cycle [(N.Name, Expr)] (Set.Set Global)
136 | Manager EffectsType
137 | Kernel KContent (Maybe KContent)
138 | PortIncoming Expr (Set.Set Global)
139 | PortOutgoing Expr (Set.Set Global)
142data EffectsType = Cmd | Sub | Fx
145data KContent =
146 KContent [KChunk] (Set.Set Global)
149data KChunk
150 = JS BS.ByteString
151 | ElmVar ModuleName.Canonical N.Name
152 | JsVar N.Name N.Name
153 | ElmField N.Name
154 | JsField Int
155 | Enum Int
156 | Debug
157 | Prod
161-- BINARY
164instance Binary Global where
165 get = liftM2 Global get get
166 put (Global a b) = put a >> put b
169instance Binary Expr where
170 put expr =
171 case expr of
172 Chr a -> putWord8 0 >> put a
173 Str a -> putWord8 1 >> put a
174 Int a -> putWord8 2 >> put a
175 Float a -> putWord8 3 >> put a
176 VarLocal a -> putWord8 4 >> put a
177 VarGlobal a -> putWord8 5 >> put a
178 VarCycle a b -> putWord8 6 >> put a >> put b
179 VarDebug a b c d -> putWord8 7 >> put a >> put b >> put c >> put d
180 VarKernel a b -> putWord8 8 >> put a >> put b
181 List a -> putWord8 9 >> put a
182 Function a b -> putWord8 10 >> put a >> put b
183 Call a b -> putWord8 11 >> put a >> put b
184 TailCall a b -> putWord8 12 >> put a >> put b
185 If a b -> putWord8 13 >> put a >> put b
186 Let a b -> putWord8 14 >> put a >> put b
187 Case a b c d -> putWord8 15 >> put a >> put b >> put c >> put d
188 Index a b -> putWord8 16 >> put a >> put b
189 Accessor a -> putWord8 17 >> put a
190 Access a b -> putWord8 18 >> put a >> put b
191 Update a b -> putWord8 19 >> put a >> put b
192 Record a -> putWord8 20 >> put a
193 Unit -> putWord8 21
194 Tuple a b c -> putWord8 22 >> put a >> put b >> put c
195 Shader a -> putWord8 23 >> put a
197 get =
198 do word <- getWord8
199 case word of
200 0 -> liftM Chr get
201 1 -> liftM Str get
202 2 -> liftM Int get
203 3 -> liftM Float get
204 4 -> liftM VarLocal get
205 5 -> liftM VarGlobal get
206 6 -> liftM2 VarCycle get get
207 7 -> liftM4 VarDebug get get get get
208 8 -> liftM2 VarKernel get get
209 9 -> liftM List get
210 10 -> liftM2 Function get get
211 11 -> liftM2 Call get get
212 12 -> liftM2 TailCall get get
213 13 -> liftM2 If get get
214 14 -> liftM2 Let get get
215 15 -> liftM4 Case get get get get
216 16 -> liftM2 Index get get
217 17 -> liftM Accessor get
218 18 -> liftM2 Access get get
219 19 -> liftM2 Update get get
220 20 -> liftM Record get
221 21 -> pure Unit
222 22 -> liftM3 Tuple get get get
223 23 -> liftM Shader get
224 _ -> error "problem getting Opt.Expr binary"
227instance Binary Def where
228 put def =
229 case def of
230 Def a b -> putWord8 0 >> put a >> put b
231 TailDef a b c -> putWord8 1 >> put a >> put b >> put c
233 get =
234 do word <- getWord8
235 case word of
236 0 -> liftM2 Def get get
237 1 -> liftM3 TailDef get get get
238 _ -> error "problem getting Opt.Def binary"
241instance (Binary a) => Binary (Decider a) where
242 put decider =
243 case decider of
244 Leaf a -> putWord8 0 >> put a
245 Chain a b c -> putWord8 1 >> put a >> put b >> put c
246 FanOut a b c -> putWord8 2 >> put a >> put b >> put c
248 get =
249 do word <- getWord8
250 case word of
251 0 -> liftM Leaf get
252 1 -> liftM3 Chain get get get
253 2 -> liftM3 FanOut get get get
254 _ -> error "problem getting Opt.Decider binary"
257instance Binary Choice where
258 put choice =
259 case choice of
260 Inline expr -> putWord8 0 >> put expr
261 Jump index -> putWord8 1 >> put index
263 get =
264 do word <- getWord8
265 case word of
266 0 -> liftM Inline get
267 1 -> liftM Jump get
268 _ -> error "problem getting Opt.Choice binary"
272instance Binary Graph where
273 get = liftM3 Graph get get get
274 put (Graph a b c) = put a >> put b >> put c
277instance Binary Main where
278 put main =
279 case main of
280 Static -> putWord8 0
281 Dynamic a b -> putWord8 1 >> put a >> put b
283 get =
284 do word <- getWord8
285 case word of
286 0 -> return Static
287 1 -> liftM2 Dynamic get get
288 _ -> error "problem getting Opt.Main binary"
291instance Binary Node where
292 put node =
293 case node of
294 Define a b -> putWord8 0 >> put a >> put b
295 DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
296 Ctor a b c -> putWord8 2 >> put a >> put b >> put c
297 Link a -> putWord8 3 >> put a
298 Cycle a b -> putWord8 4 >> put a >> put b
299 Manager a -> putWord8 5 >> put a
300 Kernel a b -> putWord8 6 >> put a >> put b
301 PortIncoming a b -> putWord8 7 >> put a >> put b
302 PortOutgoing a b -> putWord8 8 >> put a >> put b
304 get =
305 do word <- getWord8
306 case word of
307 0 -> liftM2 Define get get
308 1 -> liftM3 DefineTailFunc get get get
309 2 -> liftM3 Ctor get get get
310 3 -> liftM Link get
311 4 -> liftM2 Cycle get get
312 5 -> liftM Manager get
313 6 -> liftM2 Kernel get get
314 7 -> liftM2 PortIncoming get get
315 8 -> liftM2 PortOutgoing get get
316 _ -> error "problem getting Opt.Node binary"
319instance Binary EffectsType where
320 put effectsType =
321 case effectsType of
322 Cmd -> putWord8 0
323 Sub -> putWord8 1
324 Fx -> putWord8 2
326 get =
327 do word <- getWord8
328 case word of
329 0 -> return Cmd
330 1 -> return Sub
331 2 -> return Fx
332 _ -> error "problem getting Opt.EffectsType binary"
335instance Binary KContent where
336 get = liftM2 KContent get get
337 put (KContent a b) = put a >> put b
340instance Binary KChunk where
341 put chunk =
342 case chunk of
343 JS a -> putWord8 0 >> put a
344 ElmVar a b -> putWord8 1 >> put a >> put b
345 JsVar a b -> putWord8 2 >> put a >> put b
346 ElmField a -> putWord8 3 >> put a
347 JsField a -> putWord8 4 >> put a
348 Enum a -> putWord8 5 >> put a
349 Debug -> putWord8 6
350 Prod -> putWord8 7
352 get =
353 do word <- getWord8
354 case word of
355 0 -> liftM JS get
356 1 -> liftM2 ElmVar get get
357 2 -> liftM2 JsVar get get
358 3 -> liftM ElmField get
359 4 -> liftM JsField get
360 5 -> liftM Enum get
361 6 -> return Debug
362 7 -> return Prod
363 _ -> error "problem deserializing AST.Optimized.KChunk"