git.iko.soy/elk
on 474ec0d help sign in
elk/src/AST/Optimized.hs
360 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 Can.Type
127data Node
128 = Define Expr (Set.Set Global)
129 | DefineTailFunc [N.Name] Expr (Set.Set Global)
130 | Ctor N.Name Index.ZeroBased Int
131 | Link Global
132 | Cycle [(N.Name, Expr)] (Set.Set Global)
133 | Manager EffectsType
134 | Kernel KContent (Maybe KContent)
135 | PortIncoming Expr (Set.Set Global)
136 | PortOutgoing Expr (Set.Set Global)
139data EffectsType = Cmd | Sub | Fx
142data KContent =
143 KContent [KChunk] (Set.Set Global)
146data KChunk
147 = JS BS.ByteString
148 | ElmVar ModuleName.Canonical N.Name
149 | JsVar N.Name N.Name
150 | ElmField N.Name
151 | JsField Int
152 | Enum Int
153 | Debug
154 | Prod
158-- BINARY
161instance Binary Global where
162 get = liftM2 Global get get
163 put (Global a b) = put a >> put b
166instance Binary Expr where
167 put expr =
168 case expr of
169 Chr a -> putWord8 0 >> put a
170 Str a -> putWord8 1 >> put a
171 Int a -> putWord8 2 >> put a
172 Float a -> putWord8 3 >> put a
173 VarLocal a -> putWord8 4 >> put a
174 VarGlobal a -> putWord8 5 >> put a
175 VarCycle a b -> putWord8 6 >> put a >> put b
176 VarDebug a b c d -> putWord8 7 >> put a >> put b >> put c >> put d
177 VarKernel a b -> putWord8 8 >> put a >> put b
178 List a -> putWord8 9 >> put a
179 Function a b -> putWord8 10 >> put a >> put b
180 Call a b -> putWord8 11 >> put a >> put b
181 TailCall a b -> putWord8 12 >> put a >> put b
182 If a b -> putWord8 13 >> put a >> put b
183 Let a b -> putWord8 14 >> put a >> put b
184 Case a b c d -> putWord8 15 >> put a >> put b >> put c >> put d
185 Index a b -> putWord8 16 >> put a >> put b
186 Accessor a -> putWord8 17 >> put a
187 Access a b -> putWord8 18 >> put a >> put b
188 Update a b -> putWord8 19 >> put a >> put b
189 Record a -> putWord8 20 >> put a
190 Unit -> putWord8 21
191 Tuple a b c -> putWord8 22 >> put a >> put b >> put c
192 Shader a -> putWord8 23 >> put a
194 get =
195 do word <- getWord8
196 case word of
197 0 -> liftM Chr get
198 1 -> liftM Str get
199 2 -> liftM Int get
200 3 -> liftM Float get
201 4 -> liftM VarLocal get
202 5 -> liftM VarGlobal get
203 6 -> liftM2 VarCycle get get
204 7 -> liftM4 VarDebug get get get get
205 8 -> liftM2 VarKernel get get
206 9 -> liftM List get
207 10 -> liftM2 Function get get
208 11 -> liftM2 Call get get
209 12 -> liftM2 TailCall get get
210 13 -> liftM2 If get get
211 14 -> liftM2 Let get get
212 15 -> liftM4 Case get get get get
213 16 -> liftM2 Index get get
214 17 -> liftM Accessor get
215 18 -> liftM2 Access get get
216 19 -> liftM2 Update get get
217 20 -> liftM Record get
218 21 -> pure Unit
219 22 -> liftM3 Tuple get get get
220 23 -> liftM Shader get
221 _ -> error "problem getting Opt.Expr binary"
224instance Binary Def where
225 put def =
226 case def of
227 Def a b -> putWord8 0 >> put a >> put b
228 TailDef a b c -> putWord8 1 >> put a >> put b >> put c
230 get =
231 do word <- getWord8
232 case word of
233 0 -> liftM2 Def get get
234 1 -> liftM3 TailDef get get get
235 _ -> error "problem getting Opt.Def binary"
238instance (Binary a) => Binary (Decider a) where
239 put decider =
240 case decider of
241 Leaf a -> putWord8 0 >> put a
242 Chain a b c -> putWord8 1 >> put a >> put b >> put c
243 FanOut a b c -> putWord8 2 >> put a >> put b >> put c
245 get =
246 do word <- getWord8
247 case word of
248 0 -> liftM Leaf get
249 1 -> liftM3 Chain get get get
250 2 -> liftM3 FanOut get get get
251 _ -> error "problem getting Opt.Decider binary"
254instance Binary Choice where
255 put choice =
256 case choice of
257 Inline expr -> putWord8 0 >> put expr
258 Jump index -> putWord8 1 >> put index
260 get =
261 do word <- getWord8
262 case word of
263 0 -> liftM Inline get
264 1 -> liftM Jump get
265 _ -> error "problem getting Opt.Choice binary"
269instance Binary Graph where
270 get = liftM3 Graph get get get
271 put (Graph a b c) = put a >> put b >> put c
274instance Binary Main where
275 put main =
276 case main of
277 Static -> putWord8 0
278 Dynamic a -> putWord8 1 >> put a
280 get =
281 do word <- getWord8
282 case word of
283 0 -> return Static
284 1 -> liftM Dynamic get
285 _ -> error "problem getting Opt.Main binary"
288instance Binary Node where
289 put node =
290 case node of
291 Define a b -> putWord8 0 >> put a >> put b
292 DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
293 Ctor a b c -> putWord8 2 >> put a >> put b >> put c
294 Link a -> putWord8 3 >> put a
295 Cycle a b -> putWord8 4 >> put a >> put b
296 Manager a -> putWord8 5 >> put a
297 Kernel a b -> putWord8 6 >> put a >> put b
298 PortIncoming a b -> putWord8 7 >> put a >> put b
299 PortOutgoing a b -> putWord8 8 >> put a >> put b
301 get =
302 do word <- getWord8
303 case word of
304 0 -> liftM2 Define get get
305 1 -> liftM3 DefineTailFunc get get get
306 2 -> liftM3 Ctor get get get
307 3 -> liftM Link get
308 4 -> liftM2 Cycle get get
309 5 -> liftM Manager get
310 6 -> liftM2 Kernel get get
311 7 -> liftM2 PortIncoming get get
312 8 -> liftM2 PortOutgoing get get
313 _ -> error "problem getting Opt.Node binary"
316instance Binary EffectsType where
317 put effectsType =
318 case effectsType of
319 Cmd -> putWord8 0
320 Sub -> putWord8 1
321 Fx -> putWord8 2
323 get =
324 do word <- getWord8
325 case word of
326 0 -> return Cmd
327 1 -> return Sub
328 2 -> return Fx
329 _ -> error "problem getting Opt.EffectsType binary"
332instance Binary KContent where
333 get = liftM2 KContent get get
334 put (KContent a b) = put a >> put b
337instance Binary KChunk where
338 put chunk =
339 case chunk of
340 JS a -> putWord8 0 >> put a
341 ElmVar a b -> putWord8 1 >> put a >> put b
342 JsVar a b -> putWord8 2 >> put a >> put b
343 ElmField a -> putWord8 3 >> put a
344 JsField a -> putWord8 4 >> put a
345 Enum a -> putWord8 5 >> put a
346 Debug -> putWord8 6
347 Prod -> putWord8 7
349 get =
350 do word <- getWord8
351 case word of
352 0 -> liftM JS get
353 1 -> liftM2 ElmVar get get
354 2 -> liftM2 JsVar get get
355 3 -> liftM ElmField get
356 4 -> liftM JsField get
357 5 -> liftM Enum get
358 6 -> return Debug
359 7 -> return Prod
360 _ -> error "problem deserializing AST.Optimized.KChunk"