git.iko.soy/elk
on 4624721 help sign in
elk/src/AST/Optimized.hs
274 lines 6.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module AST.Optimized
3 ( Def(..)
4 , Expr(..)
5 , Global(..)
6 , Decider(..)
7 , Choice(..)
8 , Graph(..)
9 , Main(..)
10 , Node(..)
11 , EffectsType(..)
12 , KChunk(..)
13 )
14 where
17import Control.Monad (liftM, liftM2, liftM3, liftM4)
18import Data.Binary
19import qualified Data.ByteString as BS
20import qualified Data.Map as Map
21import qualified Data.Set as Set
22import Data.Text (Text)
24import qualified AST.Canonical as Can
25import qualified AST.Module.Name as ModuleName
26import qualified Data.Index as Index
27import qualified Elm.Name as N
28import qualified Optimize.DecisionTree as DT
29import qualified Reporting.Region as R
33-- EXPRESSIONS
36data Expr
37 = Chr Text
38 | Str Text
39 | Int Int
40 | Float Double
41 | VarLocal N.Name
42 | VarGlobal Global
43 | VarCycle ModuleName.Canonical N.Name
44 | VarDebug N.Name ModuleName.Canonical R.Region (Maybe N.Name)
45 | VarKernel N.Name N.Name
46 | List [Expr]
47 | Function [N.Name] Expr
48 | Call Expr [Expr]
49 | TailCall N.Name [(N.Name, Expr)]
50 | If [(Expr, Expr)] Expr
51 | Let Def Expr
52 | Case N.Name N.Name (Decider Choice) [(Int, Expr)]
53 | Index Expr Int
54 | Accessor N.Name
55 | Access Expr N.Name
56 | Update Expr (Map.Map N.Name Expr)
57 | Record (Map.Map N.Name Expr)
58 | Unit
59 | Tuple Expr Expr (Maybe Expr)
60 | Shader Text
63data Global = Global ModuleName.Canonical N.Name
64 deriving (Eq, Ord)
68-- DEFINITIONS
71data Def
72 = Def N.Name Expr
73 | TailDef N.Name [N.Name] Expr
77-- BRANCHING
80data Decider a
81 = Leaf a
82 | Chain
83 { _testChain :: [(DT.Path, DT.Test)]
84 , _success :: Decider a
85 , _failure :: Decider a
86 }
87 | FanOut
88 { _path :: DT.Path
89 , _tests :: [(DT.Test, Decider a)]
90 , _fallback :: Decider a
91 }
92 deriving (Eq)
95data Choice
96 = Inline Expr
97 | Jump Int
101-- OBJECT GRAPH
104data Graph =
105 Graph
106 { _mains :: Map.Map ModuleName.Canonical Main
107 , _nodes :: Map.Map Global Node
108 , _fields :: Map.Map N.Name Int
109 }
112data Main
113 = Static
114 | Dynamic Can.Type
117data Node
118 = Define Expr (Set.Set Global)
119 | DefineTailFunc [N.Name] Expr (Set.Set Global)
120 | Ctor N.Name Index.ZeroBased Int
121 | Link Global
122 | Cycle [(N.Name, Expr)] (Set.Set Global)
123 | Manager EffectsType
124 | Kernel [KChunk] (Set.Set Global) (Maybe ([KChunk], Set.Set Global))
125 | PortIncoming Expr (Set.Set Global)
126 | PortOutgoing Expr (Set.Set Global)
129data EffectsType = Cmd | Sub | Fx
132data KChunk
133 = JS BS.ByteString
134 | Var N.Name N.Name
135 | ElmField N.Name
136 | JsField Int
137 | Enum Int
138 | Debug
139 | Prod
143-- BINARY
146instance Binary Global where
147 get = liftM2 Global get get
148 put (Global a b) = put a >> put b
151instance Binary Expr where
152 put expr =
153 case expr of
154 Chr a -> putWord8 0 >> put a
155 Str a -> putWord8 1 >> put a
156 Int a -> putWord8 2 >> put a
157 Float a -> putWord8 3 >> put a
158 VarLocal a -> putWord8 4 >> put a
159 VarGlobal a -> putWord8 5 >> put a
160 VarCycle a b -> putWord8 6 >> put a >> put b
161 VarDebug a b c d -> putWord8 7 >> put a >> put b >> put c >> put d
162 VarKernel a b -> putWord8 8 >> put a >> put b
163 List a -> putWord8 9 >> put a
164 Function a b -> putWord8 10 >> put a >> put b
165 Call a b -> putWord8 11 >> put a >> put b
166 TailCall a b -> putWord8 12 >> put a >> put b
167 If a b -> putWord8 13 >> put a >> put b
168 Let a b -> putWord8 14 >> put a >> put b
169 Case a b c d -> putWord8 15 >> put a >> put b >> put c >> put d
170 Index a b -> putWord8 16 >> put a >> put b
171 Accessor a -> putWord8 17 >> put a
172 Access a b -> putWord8 18 >> put a >> put b
173 Update a b -> putWord8 19 >> put a >> put b
174 Record a -> putWord8 20 >> put a
175 Unit -> putWord8 21
176 Tuple a b c -> putWord8 22 >> put a >> put b >> put c
177 Shader a -> putWord8 23 >> put a
179 get =
180 do word <- getWord8
181 case word of
182 0 -> liftM Chr get
183 1 -> liftM Str get
184 2 -> liftM Int get
185 3 -> liftM Float get
186 4 -> liftM VarLocal get
187 5 -> liftM VarGlobal get
188 6 -> liftM2 VarCycle get get
189 7 -> liftM4 VarDebug get get get get
190 8 -> liftM2 VarKernel get get
191 9 -> liftM List get
192 10 -> liftM2 Function get get
193 11 -> liftM2 Call get get
194 12 -> liftM2 TailCall get get
195 13 -> liftM2 If get get
196 14 -> liftM2 Let get get
197 15 -> liftM4 Case get get get get
198 16 -> liftM2 Index get get
199 17 -> liftM Accessor get
200 18 -> liftM2 Access get get
201 19 -> liftM2 Update get get
202 20 -> liftM Record get
203 21 -> pure Unit
204 22 -> liftM3 Tuple get get get
205 23 -> liftM Shader get
206 _ -> error "problem getting Opt.Expr binary"
209instance Binary Def where
210 put def =
211 case def of
212 Def a b -> putWord8 0 >> put a >> put b
213 TailDef a b c -> putWord8 1 >> put a >> put b >> put c
215 get =
216 do word <- getWord8
217 case word of
218 0 -> liftM2 Def get get
219 1 -> liftM3 TailDef get get get
220 _ -> error "problem getting Opt.Def binary"
223instance (Binary a) => Binary (Decider a) where
224 put decider =
225 case decider of
226 Leaf a -> putWord8 0 >> put a
227 Chain a b c -> putWord8 1 >> put a >> put b >> put c
228 FanOut a b c -> putWord8 2 >> put a >> put b >> put c
230 get =
231 do word <- getWord8
232 case word of
233 0 -> liftM Leaf get
234 1 -> liftM3 Chain get get get
235 2 -> liftM3 FanOut get get get
236 _ -> error "problem getting Opt.Decider binary"
239instance Binary Choice where
240 put choice =
241 case choice of
242 Inline expr -> putWord8 0 >> put expr
243 Jump index -> putWord8 1 >> put index
245 get =
246 do word <- getWord8
247 case word of
248 0 -> liftM Inline get
249 1 -> liftM Jump get
250 _ -> error "problem getting Opt.Choice binary"
253instance Binary KChunk where
254 put chunk =
255 case chunk of
256 JS a -> putWord8 0 >> put a
257 Var a b -> putWord8 1 >> put a >> put b
258 ElmField a -> putWord8 2 >> put a
259 JsField a -> putWord8 3 >> put a
260 Enum a -> putWord8 4 >> put a
261 Debug -> putWord8 5
262 Prod -> putWord8 6
264 get =
265 do word <- getWord8
266 case word of
267 0 -> liftM JS get
268 1 -> liftM2 Var get get
269 2 -> liftM ElmField get
270 3 -> liftM JsField get
271 4 -> liftM Enum get
272 5 -> return Debug
273 6 -> return Prod
274 _ -> error "problem deserializing AST.Optimized.KChunk"