git.iko.soy/elk
on master help sign in
Shuffle all AST/ files around
77a954dEvan Czaplicki
src/AST/Expression/Canonical.hs → src/AST/Canonical.hsrenamed+80−13
compare with master
unifiedsplit
@@ -1,6 +1,6 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−module AST.Expression.Canonical
3+module AST.Canonical
4 ( Expr, Expr_(..)
4 ( Expr, Expr_(..)
5 , Def(..)
5 , Def(..)
6 -- patterns
6 -- patterns
@@ -10,6 +10,9 @@ module AST.Expression.Canonical
10 , PatternCtorArg(..)
10 , PatternCtorArg(..)
11 , Destructors
11 , Destructors
12 , Destructor(..)
12 , Destructor(..)
13+ -- types
14+ , Type(..)
15+ , AliasType(..)
13 -- decls
16 -- decls
14 , Decls(..)
17 , Decls(..)
15 , Decl(..)
18 , Decl(..)
@@ -27,16 +30,15 @@ module AST.Expression.Canonical
27 where
30 where
28
31
29
32
30−import Control.Monad (liftM2, liftM3)
33+import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
31import Data.Binary
34import Data.Binary
32import qualified Data.ByteString as B
35import qualified Data.ByteString as B
33import qualified Data.Map as Map
36import qualified Data.Map as Map
34import Data.Text (Text)
37import Data.Text (Text)
35
38
36−import qualified AST.Binop as Binop
39+import qualified AST.Utils.Binop as Binop
37import qualified AST.Module.Name as ModuleName
40import qualified AST.Module.Name as ModuleName
38−import qualified AST.Shader as Shader
41+import qualified AST.Utils.Shader as Shader
39−import qualified AST.Type as Type
40import qualified Data.Index as Index
42import qualified Data.Index as Index
41import qualified Elm.Name as N
43import qualified Elm.Name as N
42import Elm.Name (Name)
44import Elm.Name (Name)
@@ -90,7 +92,7 @@ data Def =
90 { _def_name :: A.Located N.Name
92 { _def_name :: A.Located N.Name
91 , _def_args :: Args
93 , _def_args :: Args
92 , _def_body :: Expr
94 , _def_body :: Expr
93− , _def_type :: Maybe Type.Canonical
95+ , _def_type :: Maybe Type
94 }
96 }
95
97
96
98
@@ -130,7 +132,7 @@ data Pattern_
130data PatternCtorArg =
132data PatternCtorArg =
131 PatternCtorArg
133 PatternCtorArg
132 { _index :: Index.ZeroBased
134 { _index :: Index.ZeroBased
133− , _type :: Type.Canonical
135+ , _type :: Type
134 , _arg :: Pattern
136 , _arg :: Pattern
135 }
137 }
136
138
@@ -144,6 +146,25 @@ data Destructor
144
146
145
147
146
148
149+-- TYPES
150+
151+
152+data Type
153+ = TLambda Type Type
154+ | TVar Name
155+ | TType ModuleName.Canonical Name [Type]
156+ | TRecord (Map.Map Name Type) (Maybe Type)
157+ | TUnit
158+ | TTuple Type Type (Maybe Type)
159+ | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType
160+
161+
162+data AliasType
163+ = Holey Type
164+ | Filled Type
165+
166+
167+
147-- DECLARATIONS
168-- DECLARATIONS
148
169
149
170
@@ -154,8 +175,8 @@ data Decls
154
175
155
176
156data Decl
177data Decl
157− = Value N.Name Expr (Maybe Type.Canonical)
178+ = Value N.Name Expr (Maybe Type)
158− | Function N.Name Args Expr (Maybe Type.Canonical)
179+ | Function N.Name Args Expr (Maybe Type)
159
180
160
181
161
182
@@ -175,8 +196,8 @@ data Module =
175 }
196 }
176
197
177
198
178−data Alias = Alias [N.Name] Type.Canonical (Maybe [N.Name])
199+data Alias = Alias [N.Name] Type (Maybe [N.Name])
179−data Union = Union [N.Name] [(N.Name, [Type.Canonical])]
200+data Union = Union [N.Name] [(N.Name, [Type])]
180data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name
201data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name
181
202
182
203
@@ -220,8 +241,8 @@ data Effects
220
241
221
242
222data Port
243data Port
223− = Incoming Type.Canonical
244+ = Incoming Type
224− | Outgoing Type.Canonical
245+ | Outgoing Type
225
246
226
247
227data Manager
248data Manager
@@ -247,3 +268,49 @@ instance Binary Union where
247instance Binary Binop where
268instance Binary Binop where
248 get = liftM3 Binop_ get get get
269 get = liftM3 Binop_ get get get
249 put (Binop_ a b c) = put a >> put b >> put c
270 put (Binop_ a b c) = put a >> put b >> put c
271+
272+
273+instance Binary Type where
274+ put tipe =
275+ case tipe of
276+ TLambda a b -> putWord8 0 >> put a >> put b
277+ TVar a -> putWord8 1 >> put a
278+ TRecord a b -> putWord8 2 >> put a >> put b
279+ TUnit -> putWord8 3
280+ TTuple a b c -> putWord8 4 >> put a >> put b >> put c
281+ TAlias a b c d -> putWord8 5 >> put a >> put b >> put c >> put d
282+ TType home name ts ->
283+ let potentialWord = length ts + 7 in
284+ if potentialWord <= fromIntegral (maxBound :: Word8) then
285+ do putWord8 (fromIntegral potentialWord)
286+ put home
287+ put name
288+ mapM_ put ts
289+ else
290+ putWord8 6 >> put home >> put name >> put ts
291+
292+ get =
293+ do word <- getWord8
294+ case word of
295+ 0 -> liftM2 TLambda get get
296+ 1 -> liftM TVar get
297+ 2 -> liftM2 TRecord get get
298+ 3 -> return TUnit
299+ 4 -> liftM3 TTuple get get get
300+ 5 -> liftM4 TAlias get get get get
301+ 6 -> liftM3 TType get get get
302+ n -> liftM3 TType get get (replicateM (fromIntegral (n - 7)) get)
303+
304+
305+instance Binary AliasType where
306+ put aliasType =
307+ case aliasType of
308+ Holey tipe -> putWord8 0 >> put tipe
309+ Filled tipe -> putWord8 1 >> put tipe
310+
311+ get =
312+ do n <- getWord8
313+ case n of
314+ 0 -> liftM Holey get
315+ 1 -> liftM Filled get
316+ _ -> error "Error reading a valid type from serialized string"
src/AST/Expression/Optimized.hs → src/AST/Optimized.hsrenamed+121−130
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module AST.Expression.Optimized
2+module AST.Optimized
3 ( Decl(..)
3 ( Decl(..)
4 , Def(..)
4 , Def(..)
5 , Expr(..)
5 , Expr(..)
@@ -14,7 +14,6 @@ import Data.Binary
14import qualified Data.Set as Set
14import qualified Data.Set as Set
15import Data.Text (Text)
15import Data.Text (Text)
16
16
17−import qualified AST.Effects as Effects
18import qualified AST.Literal as Literal
17import qualified AST.Literal as Literal
19import qualified AST.Module.Name as ModuleName
18import qualified AST.Module.Name as ModuleName
20import qualified AST.Variable as Var
19import qualified AST.Variable as Var
@@ -23,16 +22,31 @@ import qualified Reporting.Region as R
23
22
24
23
25
24
26−-- TOP LEVEL DECLARATIONS
25+-- EXPRESSIONS
27
26
28
27
29−data Decl =
28+data Expr
30− Decl
29+ = Literal Literal.Literal
30+ | VarLocal Text
31− { _direct :: Set.Set Var.Global
31+ | VarGlobal Var.Global
32− , _indirect :: Set.Set Var.Global
32+ | List [Expr]
33− , _effects :: Maybe Effects.ManagerType
33+ | Binop Var.Global Expr Expr
34− , _body :: !Def
34+ | Function [Text] Expr
35− }
35+ | Call Expr [Expr]
36+ | TailCall Text [Text] [Expr]
37+ | If [(Expr, Expr)] Expr
38+ | Let [(Text, Def)] Expr
39+ | Case Text (Decider Choice) [(Int, Expr)]
40+ | Ctor Text [Expr]
41+ | CtorAccess Expr Int
42+ | Accessor Text
43+ | Access Expr Text
44+ | Update Expr [(Text, Expr)]
45+ | Record [(Text, Expr)]
46+ | Unit
47+ | Tuple Expr Expr [Expr]
48+ | GLShader Text
49+ | Crash ModuleName.Canonical R.Region (Maybe Expr)
36
50
37
51
38
52
@@ -45,90 +59,86 @@ data Def
45
59
46
60
47
61
48−-- EXPRESSIONS
62+-- BRANCHING
49−
50−
51−data Expr
52− = Literal Literal.Literal
53− | VarLocal Text
54− | VarGlobal Var.Global
55− | List [Expr]
56− | Binop Var.Global Expr Expr
57− | Function [Text] Expr
58− | Call Expr [Expr]
59− | TailCall Text [Text] [Expr]
60− | If [(Expr, Expr)] Expr
61− | Let [(Text, Def)] Expr
62− | Case Text (Decider Choice) [(Int, Expr)]
63− | Ctor Text [Expr]
64− | CtorAccess Expr Int
65− | Access Expr Text
66− | Update Expr [(Text, Expr)]
67− | Record [(Text, Expr)]
68− | Cmd ModuleName.Canonical Effects.ManagerType
69− | Sub ModuleName.Canonical Effects.ManagerType
70− | OutgoingPort Text Expr
71− | IncomingPort Text Expr
72− | Program Main Expr
73− | GLShader Text
74− | Crash ModuleName.Canonical R.Region (Maybe Expr)
75−
76−
77−data Main
78− = Static
79− | Dynamic Expr
80
63
81
64
82data Decider a
65data Decider a
83− = Leaf a
66+ = Leaf a
84− | Chain
67+ | Chain
85− { _testChain :: [(DT.Path, DT.Test)]
68+ { _testChain :: [(DT.Path, DT.Test)]
86− , _success :: Decider a
69+ , _success :: Decider a
87− , _failure :: Decider a
70+ , _failure :: Decider a
88− }
71+ }
89− | FanOut
72+ | FanOut
90− { _path :: DT.Path
73+ { _path :: DT.Path
91− , _tests :: [(DT.Test, Decider a)]
74+ , _tests :: [(DT.Test, Decider a)]
92− , _fallback :: Decider a
75+ , _fallback :: Decider a
93− }
76+ }
94− deriving (Eq)
77+ deriving (Eq)
95
78
96
79
97data Choice
80data Choice
98− = Inline Expr
81+ = Inline Expr
99− | Jump Int
82+ | Jump Int
100
83
101
84
102
85
103−-- BINARY
86+-- OBJECT GRAPH
104
87
105
88
106−instance Binary Decl where
89+data Graph =
107− get =
90+ Graph
108− liftM4 Decl get get get get
91+ { _nodes :: Map.Map Var.Global Node
92+ }
109
93
110− put (Decl direct indirect fx body) =
111− put direct >> put indirect >> put fx >> put body
112
94
113
95
114−instance Binary Def where
96+data Node
115− get =
97+ = Acyclic
116− do word <- getWord8
98+ { _deps :: [Var.Global]
117− case word of
99+ , _body :: Expr
118− 0 -> Def <$> get
100+ }
119− 1 -> TailDef <$> get <*> get
101+ | TailCall
120− _ -> error "problem getting Opt.Def binary"
102+ { _deps :: [Var.Global]
103+ , _args :: [Text]
104+ , _body :: Expr
105+ }
106+ | Cyclic Var.Global
107+ | Cycle
108+ { _deps :: [Var.Global]
109+ , _values :: [(Var.Global, Expr)]
110+ }
111+
121
112
122− put def =
123− case def of
124− Def body ->
125− putWord8 0 >> put body
126
113
127− TailDef args body ->
114+-- BINARY
128− putWord8 1 >> put args >> put body
129
115
130
116
131instance Binary Expr where
117instance Binary Expr where
118+ put expr =
119+ case expr of
120+ Literal a -> putWord8 0 >> put a
121+ VarLocal a -> putWord8 1 >> put a
122+ VarGlobal a -> putWord8 2 >> put a
123+ List a -> putWord8 3 >> put a
124+ Binop a b c -> putWord8 4 >> put a >> put b >> put c
125+ Function a b -> putWord8 5 >> put a >> put b
126+ Call a b -> putWord8 6 >> put a >> put b
127+ TailCall a b c -> putWord8 7 >> put a >> put b >> put c
128+ If a b -> putWord8 8 >> put a >> put b
129+ Let a b -> putWord8 9 >> put a >> put b
130+ Case a b c -> putWord8 10 >> put a >> put b >> put c
131+ Ctor a b -> putWord8 11 >> put a >> put b
132+ CtorAccess a b -> putWord8 12 >> put a >> put b
133+ Accessor a -> putWord8 13 >> put a
134+ Access a b -> putWord8 14 >> put a >> put b
135+ Update a b -> putWord8 15 >> put a >> put b
136+ Record a -> putWord8 16 >> put a
137+ Unit -> putWord8 17
138+ Tuple a b c -> putWord8 18 >> put a >> put b >> put c
139+ GLShader a -> putWord8 19 >> put a
140+ Crash a b c -> putWord8 20 >> put a >> put b >> put c
141+
132 get =
142 get =
133 do word <- getWord8
143 do word <- getWord8
134 case word of
144 case word of
@@ -145,43 +155,37 @@ instance Binary Expr where
145 10 -> liftM3 Case get get get
155 10 -> liftM3 Case get get get
146 11 -> liftM2 Ctor get get
156 11 -> liftM2 Ctor get get
147 12 -> liftM2 CtorAccess get get
157 12 -> liftM2 CtorAccess get get
158+ 13 -> liftM Accessor get
148− 13 -> liftM2 Access get get
159+ 14 -> liftM2 Access get get
149− 14 -> liftM2 Update get get
160+ 15 -> liftM2 Update get get
150− 15 -> liftM Record get
161+ 16 -> liftM Record get
151− 16 -> liftM2 Cmd get get
162+ 17 -> pure Unit
152− 17 -> liftM2 Sub get get
163+ 18 -> liftM3 Tuple get get get
153− 18 -> liftM2 OutgoingPort get get
164+ 19 -> liftM GLShader get
154− 19 -> liftM2 IncomingPort get get
155− 20 -> liftM2 Program get get
156− 21 -> liftM GLShader get
157− 22 -> liftM3 Crash get get get
165+ 20 -> liftM3 Crash get get get
158 _ -> error "problem getting Opt.Expr binary"
166 _ -> error "problem getting Opt.Expr binary"
159
167
160− put expr =
168+
169+instance Binary Decl where
170+ put (Decl a b c d) =
171+ put a >> put b >> put c >> put d
172+
173+ get =
174+ liftM4 Decl get get get get
175+
176+
177+instance Binary Def where
178+ put def =
161− case expr of
179+ case def of
162− Literal a -> putWord8 0 >> put a
180+ Def body -> putWord8 0 >> put body
163− VarLocal a -> putWord8 1 >> put a
181+ TailDef args body -> putWord8 1 >> put args >> put body
164− VarGlobal a -> putWord8 2 >> put a
182+
165− List a -> putWord8 3 >> put a
183+ get =
166− Binop a b c -> putWord8 4 >> put a >> put b >> put c
184+ do word <- getWord8
167− Function a b -> putWord8 5 >> put a >> put b
185+ case word of
168− Call a b -> putWord8 6 >> put a >> put b
186+ 0 -> Def <$> get
169− TailCall a b c -> putWord8 7 >> put a >> put b >> put c
187+ 1 -> TailDef <$> get <*> get
170− If a b -> putWord8 8 >> put a >> put b
188+ _ -> error "problem getting Opt.Def binary"
171− Let a b -> putWord8 9 >> put a >> put b
172− Case a b c -> putWord8 10 >> put a >> put b >> put c
173− Ctor a b -> putWord8 11 >> put a >> put b
174− CtorAccess a b -> putWord8 12 >> put a >> put b
175− Access a b -> putWord8 13 >> put a >> put b
176− Update a b -> putWord8 14 >> put a >> put b
177− Record a -> putWord8 15 >> put a
178− Cmd a b -> putWord8 16 >> put a >> put b
179− Sub a b -> putWord8 17 >> put a >> put b
180− OutgoingPort a b -> putWord8 18 >> put a >> put b
181− IncomingPort a b -> putWord8 19 >> put a >> put b
182− Program a b -> putWord8 20 >> put a >> put b
183− GLShader a -> putWord8 21 >> put a
184− Crash a b c -> putWord8 22 >> put a >> put b >> put c
185
189
186
190
187instance Binary Main where
191instance Binary Main where
@@ -199,6 +203,12 @@ instance Binary Main where
199
203
200
204
201instance (Binary a) => Binary (Decider a) where
205instance (Binary a) => Binary (Decider a) where
206+ put decider =
207+ case decider of
208+ Leaf a -> putWord8 0 >> put a
209+ Chain a b c -> putWord8 1 >> put a >> put b >> put c
210+ FanOut a b c -> putWord8 2 >> put a >> put b >> put c
211+
202 get =
212 get =
203 do word <- getWord8
213 do word <- getWord8
204 case word of
214 case word of
@@ -207,30 +217,12 @@ instance (Binary a) => Binary (Decider a) where
207 2 -> liftM3 FanOut get get get
217 2 -> liftM3 FanOut get get get
208 _ -> error "problem getting Opt.Decider binary"
218 _ -> error "problem getting Opt.Decider binary"
209
219
210− put decider =
211− case decider of
212− Leaf a ->
213− do putWord8 0
214− put a
215−
216− Chain testChain success failure ->
217− do putWord8 1
218− put testChain
219− put success
220− put failure
221−
222− FanOut path tests fallback ->
223− do putWord8 2
224− put path
225− put tests
226− put fallback
227−
228
220
229instance Binary Choice where
221instance Binary Choice where
230 put choice =
222 put choice =
231 case choice of
223 case choice of
232 Inline expr -> putWord8 0 >> put expr
224 Inline expr -> putWord8 0 >> put expr
233− Jump index -> putWord8 1 >> put index
225+ Jump index -> putWord8 1 >> put index
234
226
235 get =
227 get =
236 do word <- getWord8
228 do word <- getWord8
@@ -238,4 +230,3 @@ instance Binary Choice where
238 0 -> liftM Inline get
230 0 -> liftM Inline get
239 1 -> liftM Jump get
231 1 -> liftM Jump get
240 _ -> error "problem getting Opt.Choice binary"
232 _ -> error "problem getting Opt.Choice binary"
241−
src/AST/Expression/Source.hs → src/AST/Source.hsrenamed+26−9
@@ -1,10 +1,11 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−module AST.Expression.Source
3+module AST.Source
4 ( Expr, Expr_(..)
4 ( Expr, Expr_(..)
5 , Decl, Decl_(..)
5 , Decl, Decl_(..)
6 , Def(..)
6 , Def(..)
7 , Pattern, Pattern_(..)
7 , Pattern, Pattern_(..)
8+ , Type, Type_(..)
8 , Module(..)
9 , Module(..)
9 , Import(..)
10 , Import(..)
10 , Effects(..)
11 , Effects(..)
@@ -20,9 +21,8 @@ module AST.Expression.Source
20import qualified Data.ByteString as B
21import qualified Data.ByteString as B
21import Data.Text (Text)
22import Data.Text (Text)
22
23
23−import qualified AST.Binop as Binop
24+import qualified AST.Utils.Binop as Binop
24−import qualified AST.Shader as Shader
25+import qualified AST.Utils.Shader as Shader
25−import qualified AST.Type as Type
26import qualified Elm.Name as N
26import qualified Elm.Name as N
27import qualified Reporting.Annotation as A
27import qualified Reporting.Annotation as A
28import qualified Reporting.Region as R
28import qualified Reporting.Region as R
@@ -64,7 +64,7 @@ data Expr_
64
64
65
65
66data Def
66data Def
67− = Annotate N.Name Type.Raw
67+ = Annotate N.Name Type
68 | Define (A.Located N.Name) [Pattern] Expr
68 | Define (A.Located N.Name) [Pattern] Expr
69 | Destruct Pattern Expr
69 | Destruct Pattern Expr
70
70
@@ -92,6 +92,23 @@ data Pattern_
92
92
93
93
94
94
95+-- TYPE
96+
97+
98+type Type =
99+ A.Located Type_
100+
101+
102+data Type_
103+ = TLambda Type Type
104+ | TVar N.Name
105+ | TType R.Region (Maybe N.Name) N.Name [Type]
106+ | TRecord [(A.Located N.Name, Type)] (Maybe Type)
107+ | TUnit
108+ | TTuple Type Type [Type]
109+
110+
111+
95-- DECLARATIONS
112-- DECLARATIONS
96
113
97
114
@@ -99,12 +116,12 @@ type Decl = A.Located Decl_
99
116
100
117
101data Decl_
118data Decl_
102− = Union (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Type.Raw])]
119+ = Union (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Type])]
103− | Alias (A.Located N.Name) [A.Located N.Name] Type.Raw
120+ | Alias (A.Located N.Name) [A.Located N.Name] Type
104 | Binop (A.Located N.Name) Binop.Associativity Binop.Precedence N.Name
121 | Binop (A.Located N.Name) Binop.Associativity Binop.Precedence N.Name
105− | Port (A.Located N.Name) Type.Raw
122+ | Port (A.Located N.Name) Type
106 | Docs Text
123 | Docs Text
107− | Annotation (A.Located N.Name) Type.Raw
124+ | Annotation (A.Located N.Name) Type
108 | Definition (A.Located N.Name) [Pattern] Expr
125 | Definition (A.Located N.Name) [Pattern] Expr
109
126
110
127
src/AST/Type.hsdeleted−229
@@ -1,229 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module AST.Type
4− ( Raw, Raw'(..)
5− , Canonical(..), Aliased(..)
6− , Super(..)
7− , deepDealias, iteratedDealias, dealias
8− , collectLambdas
9− , cmd, sub
10− )
11− where
12−
13−
14−import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
15−import Data.Binary
16−import qualified Data.Map as Map
17−
18−import qualified AST.Module.Name as ModuleName
19−import Elm.Name (Name)
20−import qualified Reporting.Annotation as A
21−import qualified Reporting.Region as R
22−
23−
24−
25−-- DEFINITION
26−
27−
28−type Raw =
29− A.Located Raw'
30−
31−
32−data Raw'
33− = RLambda Raw Raw
34− | RVar Name
35− | RType R.Region (Maybe Name) Name [Raw]
36− | RRecord [(A.Located Name, Raw)] (Maybe Raw)
37− | RUnit
38− | RTuple Raw Raw [Raw]
39−
40−
41−data Canonical
42− = Lambda Canonical Canonical
43− | Var Name
44− | Type ModuleName.Canonical Name [Canonical]
45− | Record (Map.Map Name Canonical) (Maybe Canonical)
46− | Unit
47− | Tuple Canonical Canonical (Maybe Canonical)
48− | Aliased ModuleName.Canonical Name [(Name, Canonical)] (Aliased Canonical)
49− deriving (Eq, Ord)
50−
51−
52−data Aliased t
53− = Holey t
54− | Filled t
55− deriving (Eq, Ord)
56−
57−
58−data Super
59− = Number
60− | Comparable
61− | Appendable
62− | CompAppend
63− deriving (Eq)
64−
65−
66−
67−-- CONSTRUCT USEFUL TYPES
68−
69−
70−cmd :: ModuleName.Canonical -> Name -> Canonical
71−cmd home tipe =
72− Lambda
73− (Type home tipe [Var "msg"])
74− (Type ModuleName.cmd "Cmd" [Var "msg"])
75−
76−
77−sub :: ModuleName.Canonical -> Name -> Canonical
78−sub home tipe =
79− Lambda
80− (Type home tipe [Var "msg"])
81− (Type ModuleName.sub "Sub" [Var "msg"])
82−
83−
84−
85−-- DEALIASING
86−
87−
88−deepDealias :: Canonical -> Canonical
89−deepDealias tipe =
90− case tipe of
91− Lambda a b ->
92− Lambda (deepDealias a) (deepDealias b)
93−
94− Var _ ->
95− tipe
96−
97− Record fields ext ->
98− Record (Map.map deepDealias fields) (fmap deepDealias ext)
99−
100− Aliased _ _ args tipe' ->
101− deepDealias (dealias args tipe')
102−
103− Type home name args ->
104− Type home name (map deepDealias args)
105−
106− Unit ->
107− Unit
108−
109− Tuple a b c ->
110− Tuple (deepDealias a) (deepDealias b) (fmap deepDealias c)
111−
112−
113−iteratedDealias :: Canonical -> Canonical
114−iteratedDealias tipe =
115− case tipe of
116− Aliased _ _ args realType ->
117− iteratedDealias (dealias args realType)
118−
119− _ ->
120− tipe
121−
122−
123−dealias :: [(Name, Canonical)] -> Aliased Canonical -> Canonical
124−dealias args aliasType =
125− case aliasType of
126− Holey tipe ->
127− dealiasHelp (Map.fromList args) tipe
128−
129− Filled tipe ->
130− tipe
131−
132−
133−dealiasHelp :: Map.Map Name Canonical -> Canonical -> Canonical
134−dealiasHelp typeTable tipe =
135− let
136− go =
137− dealiasHelp typeTable
138− in
139− case tipe of
140− Lambda a b ->
141− Lambda (go a) (go b)
142−
143− Var x ->
144− Map.findWithDefault tipe x typeTable
145−
146− Record fields ext ->
147− Record (Map.map go fields) (fmap go ext)
148−
149− Aliased home name args t' ->
150− Aliased home name (map (fmap go) args) t'
151−
152− Type home name args ->
153− Type home name (map go args)
154−
155− Unit ->
156− Unit
157−
158− Tuple a b c ->
159− Tuple (go a) (go b) (fmap go c)
160−
161−
162−
163−-- COLLECT LAMBDAS
164−
165−
166−collectLambdas :: Canonical -> [Canonical]
167−collectLambdas tipe =
168− case tipe of
169− Lambda arg result ->
170− arg : collectLambdas result
171−
172− _ ->
173− [tipe]
174−
175−
176−
177−-- BINARY
178−
179−
180−instance Binary Canonical where
181− put tipe =
182− case tipe of
183− Lambda a b -> putWord8 0 >> put a >> put b
184− Var a -> putWord8 1 >> put a
185− Record a b -> putWord8 2 >> put a >> put b
186− Unit -> putWord8 3
187− Tuple a b c -> putWord8 4 >> put a >> put b >> put c
188− Aliased a b c d -> putWord8 5 >> put a >> put b >> put c >> put d
189− Type home name ts ->
190− let
191− potentialWord =
192− length ts + 7
193− in
194− if potentialWord <= fromIntegral (maxBound :: Word8) then
195− do putWord8 (fromIntegral potentialWord)
196− put home
197− put name
198− mapM_ put ts
199− else
200− putWord8 6 >> put home >> put name >> put ts
201−
202− get =
203− do word <- getWord8
204− case word of
205− 0 -> liftM2 Lambda get get
206− 1 -> liftM Var get
207− 2 -> liftM2 Record get get
208− 3 -> return Unit
209− 4 -> liftM3 Tuple get get get
210− 5 -> liftM4 Aliased get get get get
211− 6 -> liftM3 Type get get get
212− n -> liftM3 Type get get (replicateM (fromIntegral (n - 7)) get)
213−
214−
215−instance Binary t => Binary (Aliased t) where
216− put aliasType =
217− case aliasType of
218− Holey tipe ->
219− putWord8 0 >> put tipe
220−
221− Filled tipe ->
222− putWord8 1 >> put tipe
223−
224− get =
225− do n <- getWord8
226− case n of
227− 0 -> liftM Holey get
228− 1 -> liftM Filled get
229− _ -> error "Error reading a valid type from serialized string"
src/AST/Binop.hs → src/AST/Utils/Binop.hsrenamed+1−1
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module AST.Binop
2+module AST.Utils.Binop
3 ( Precedence
3 ( Precedence
4 , Associativity(..)
4 , Associativity(..)
5 )
5 )
src/AST/Kernel.hs → src/AST/Utils/Kernel.hsrenamed+1−1
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module AST.Kernel
2+module AST.Utils.Kernel
3 ( Data(..)
3 ( Data(..)
4 , Content(..)
4 , Content(..)
5 , Chunk(..)
5 , Chunk(..)
src/AST/Shader.hs → src/AST/Utils/Shader.hsrenamed+1−1
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module AST.Shader
2+module AST.Utils.Shader
3 ( Shader(..)
3 ( Shader(..)
4 , Type(..)
4 , Type(..)
5 )
5 )
src/AST/Utils/Type.hsnew file+118
@@ -0,0 +1,118 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module AST.Utils.Type
4+ ( delambda
5+ , dealias
6+ , deepDealias
7+ , iteratedDealias
8+ )
9+ where
10+
11+
12+import qualified Data.Map as Map
13+
14+import AST.Canonical (Type(..), AliasType(..))
15+import qualified Elm.Name as N
16+
17+
18+
19+-- DELAMBDA
20+
21+
22+delambda :: Type -> [Type]
23+delambda tipe =
24+ case tipe of
25+ TLambda arg result ->
26+ arg : delambda result
27+
28+ _ ->
29+ [tipe]
30+
31+
32+
33+-- DEALIAS
34+
35+
36+dealias :: [(N.Name, Type)] -> AliasType -> Type
37+dealias args aliasType =
38+ case aliasType of
39+ Holey tipe ->
40+ dealiasHelp (Map.fromList args) tipe
41+
42+ Filled tipe ->
43+ tipe
44+
45+
46+dealiasHelp :: Map.Map N.Name Type -> Type -> Type
47+dealiasHelp typeTable tipe =
48+ case tipe of
49+ TLambda a b ->
50+ TLambda
51+ (dealiasHelp typeTable a)
52+ (dealiasHelp typeTable b)
53+
54+ TVar x ->
55+ Map.findWithDefault tipe x typeTable
56+
57+ TRecord fields ext ->
58+ TRecord
59+ (Map.map (dealiasHelp typeTable) fields)
60+ (fmap (dealiasHelp typeTable) ext)
61+
62+ TAlias home name args t' ->
63+ TAlias home name (map (fmap (dealiasHelp typeTable)) args) t'
64+
65+ TType home name args ->
66+ TType home name (map (dealiasHelp typeTable) args)
67+
68+ TUnit ->
69+ TUnit
70+
71+ TTuple a b maybeC ->
72+ TTuple
73+ (dealiasHelp typeTable a)
74+ (dealiasHelp typeTable b)
75+ (fmap (dealiasHelp typeTable) maybeC)
76+
77+
78+
79+-- DEEP DEALIAS
80+
81+
82+deepDealias :: Type -> Type
83+deepDealias tipe =
84+ case tipe of
85+ TLambda a b ->
86+ TLambda (deepDealias a) (deepDealias b)
87+
88+ TVar _ ->
89+ tipe
90+
91+ TRecord fields ext ->
92+ TRecord (Map.map deepDealias fields) (fmap deepDealias ext)
93+
94+ TAlias _ _ args tipe' ->
95+ deepDealias (dealias args tipe')
96+
97+ TType home name args ->
98+ TType home name (map deepDealias args)
99+
100+ TUnit ->
101+ TUnit
102+
103+ TTuple a b c ->
104+ TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c)
105+
106+
107+
108+-- ITERATED DEALIAS
109+
110+
111+iteratedDealias :: Type -> Type
112+iteratedDealias tipe =
113+ case tipe of
114+ TAlias _ _ args realType ->
115+ iteratedDealias (dealias args realType)
116+
117+ _ ->
118+ tipe
src/AST/Expression/Valid.hs → src/AST/Valid.hsrenamed+9−10
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module AST.Expression.Valid
2+module AST.Valid
3 ( Expr, Expr_(..)
3 ( Expr, Expr_(..)
4 , Def(..)
4 , Def(..)
5 , Module(..)
5 , Module(..)
@@ -18,10 +18,9 @@ import qualified Data.ByteString as B
18import qualified Data.Map as Map
18import qualified Data.Map as Map
19import Data.Text (Text)
19import Data.Text (Text)
20
20
21−import qualified AST.Binop as Binop
21+import qualified AST.Utils.Binop as Binop
22−import qualified AST.Expression.Source as Src
22+import qualified AST.Source as Src
23−import qualified AST.Shader as Shader
23+import qualified AST.Utils.Shader as Shader
24−import qualified AST.Type as Type
25import qualified Elm.Name as N
24import qualified Elm.Name as N
26import qualified Reporting.Annotation as A
25import qualified Reporting.Annotation as A
27import qualified Reporting.Region as R
26import qualified Reporting.Region as R
@@ -63,7 +62,7 @@ data Expr_
63
62
64
63
65data Def
64data Def
66− = Define R.Region (A.Located N.Name) [Src.Pattern] Expr (Maybe Type.Raw)
65+ = Define R.Region (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type)
67 | Destruct R.Region Src.Pattern Expr
66 | Destruct R.Region Src.Pattern Expr
68
67
69
68
@@ -86,9 +85,9 @@ data Module =
86 }
85 }
87
86
88
87
89−data Decl = Decl (A.Located N.Name) [Src.Pattern] Expr (Maybe Type.Raw)
88+data Decl = Decl (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type)
90−data Union = Union (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Type.Raw])]
89+data Union = Union (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Src.Type])]
91−data Alias = Alias (A.Located N.Name) [A.Located N.Name] Type.Raw
90+data Alias = Alias (A.Located N.Name) [A.Located N.Name] Src.Type
92data Binop = Binop (A.Located N.Name) Binop.Associativity Binop.Precedence N.Name
91data Binop = Binop (A.Located N.Name) Binop.Associativity Binop.Precedence N.Name
93
92
94
93
@@ -104,4 +103,4 @@ data Manager
104 | Fx (A.Located N.Name) (A.Located N.Name)
103 | Fx (A.Located N.Name) (A.Located N.Name)
105
104
106
105
107−data Port = Port (A.Located N.Name) Type.Raw
106+data Port = Port (A.Located N.Name) Src.Type