git.iko.soy/elk
on master help sign in
Add ops, accessors, unit, and tuples to source AST
9111afaEvan Czaplicki
src/AST/Expression/Source.hs+14−25
compare with master
unifiedsplit
@@ -3,17 +3,16 @@ module AST.Expression.Source
3 ( RawExpr, RawExpr', RawDef, RawDef'(..)
3 ( RawExpr, RawExpr', RawDef, RawDef'(..)
4 , ValidExpr, ValidExpr', ValidDef(..)
4 , ValidExpr, ValidExpr', ValidDef(..)
5 , Expr, Expr'(..)
5 , Expr, Expr'(..)
6− , var, tuple, zero, getPattern, collectLambdas
6+ , zero, collectLambdas
7 )
7 )
8 where
8 where
9
9
10+
10import Data.Text (Text)
11import Data.Text (Text)
11
12
12−import qualified AST.Helpers as Help
13import qualified AST.Literal as Literal
13import qualified AST.Literal as Literal
14import qualified AST.Pattern as Ptrn
14import qualified AST.Pattern as Ptrn
15import qualified AST.Type as Type
15import qualified AST.Type as Type
16−import qualified AST.Variable as Var
17import qualified Reporting.Annotation as A
16import qualified Reporting.Annotation as A
18import qualified Reporting.Region as R
17import qualified Reporting.Region as R
19
18
@@ -28,18 +27,21 @@ type Expr def =
28
27
29data Expr' def
28data Expr' def
30 = Literal Literal.Literal
29 = Literal Literal.Literal
31− | Var Var.Raw
30+ | Var (Maybe Text) Text
32 | List [Expr def]
31 | List [Expr def]
32+ | Op Text
33 | Binop [(Expr def, A.Located Text)] (Expr def)
33 | Binop [(Expr def, A.Located Text)] (Expr def)
34 | Lambda Ptrn.Raw (Expr def)
34 | Lambda Ptrn.Raw (Expr def)
35 | App (Expr def) (Expr def)
35 | App (Expr def) (Expr def)
36 | If [(Expr def, Expr def)] (Expr def)
36 | If [(Expr def, Expr def)] (Expr def)
37 | Let [def] (Expr def)
37 | Let [def] (Expr def)
38 | Case (Expr def) [(Ptrn.Raw, Expr def)]
38 | Case (Expr def) [(Ptrn.Raw, Expr def)]
39− | Ctor Text [Expr def]
39+ | Accessor Text
40 | Access (Expr def) Text
40 | Access (Expr def) Text
41− | Update (Expr def) [(A.Located Text, Expr def)]
41+ | Update (A.Located Text) [(A.Located Text, Expr def)]
42 | Record [(A.Located Text, Expr def)]
42 | Record [(A.Located Text, Expr def)]
43+ | Unit
44+ | Tuple (Expr def) (Expr def) [Expr def]
43 | GLShader Text Text Literal.Shader
45 | GLShader Text Text Literal.Shader
44
46
45
47
@@ -61,38 +63,25 @@ type RawDef =
61
63
62
64
63data RawDef'
65data RawDef'
64− = Definition Ptrn.Raw RawExpr
65− | Annotation Text Type.Raw
66+ = Annotation Text Type.Raw
67+ | Definition Text [Ptrn.Raw] RawExpr
68+ | Destructure Ptrn.Raw RawExpr
66
69
67
70
68−data ValidDef =
71+data ValidDef
69− Def R.Region Ptrn.Raw ValidExpr (Maybe Type.Raw)
72+ = VDefinition R.Region Text [Ptrn.Raw] ValidExpr (Maybe Type.Raw)
73+ | VDestructure R.Region Ptrn.Raw ValidExpr
70
74
71
75
72
76
73-- HELPERS
77-- HELPERS
74
78
75
79
76−var :: Text -> Expr' def
77−var x =
78− Var (Var.Raw x)
79−
80−
81−tuple :: [Expr def] -> Expr' def
82−tuple expressions =
83− Ctor (Help.makeTuple (length expressions)) expressions
84−
85−
86zero :: Expr' def
80zero :: Expr' def
87zero =
81zero =
88 Literal (Literal.IntNum 0)
82 Literal (Literal.IntNum 0)
89
83
90
84
91−getPattern :: ValidDef -> Ptrn.Raw
92−getPattern (Def _ pattern _ _) =
93− pattern
94−
95−
96collectLambdas :: Expr def -> ([Ptrn.Raw], Expr def)
85collectLambdas :: Expr def -> ([Ptrn.Raw], Expr def)
97collectLambdas lexpr@(A.A _ expr) =
86collectLambdas lexpr@(A.A _ expr) =
98 case expr of
87 case expr of
src/AST/Pattern.hs+61−109
@@ -1,160 +1,112 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−module AST.Pattern where
3+module AST.Pattern
4+ ( Raw
5+ , Raw_(..)
6+ , Canonical
7+ , Canonical_(..)
8+ , boundVars
9+ , member
10+ , boundVarSet
11+ , boundVarList
12+ )
13+ where
14+
4
15
5−import qualified Data.List as List
6−import Data.Monoid ((<>))
7import qualified Data.Set as Set
16import qualified Data.Set as Set
8import Data.Text (Text)
17import Data.Text (Text)
9−import qualified Data.Text.Lazy as LazyText
10−import Data.Text.Lazy.Builder (Builder, fromText, toLazyText)
11
18
12−import qualified AST.Helpers as Help
13import qualified AST.Literal as L
19import qualified AST.Literal as L
14import qualified AST.Variable as Var
20import qualified AST.Variable as Var
15import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
16−import qualified Reporting.Region as R
17
22
18
23
19−type Pattern ann var =
20− A.Annotated ann (Pattern' ann var)
21
24
25+-- RAW
22
26
23−data Pattern' ann var
24− = Ctor var [Pattern ann var]
25− | Record [Text]
26− | Alias Text (Pattern ann var)
27− | Var Text
28− | Anything
29− | Literal L.Literal
30
27
28+type Raw = A.Located Raw_
31
29
32−type Raw =
33− Pattern R.Region Var.Raw
34
30
31+data Raw_
32+ = RCtor (Maybe Text) Text [Raw]
33+ | RRecord [Text]
34+ | RUnit
35+ | RTuple Raw Raw [Raw]
36+ | RList [Raw]
37+ | RCons Raw Raw
38+ | RAlias Text Raw
39+ | RVar Text
40+ | RAnything
41+ | RLiteral L.Literal
35
42
36−type Raw' =
37− Pattern' R.Region Var.Raw
38
43
39
44
40−type Canonical =
45+-- CANONICAL
41− Pattern R.Region Var.Canonical
42
46
43
47
44−isVar :: Text -> Pattern ann var -> Bool
48+type Canonical = A.Located Canonical_
45−isVar name (A.A _ pattern) =
46− case pattern of
47− Var pName ->
48− name == pName
49
49
50− _ ->
51− False
52
50
51+data Canonical_
52+ = Ctor Var.Canonical [Canonical]
53+ | Record [Text]
54+ | Unit
55+ | Tuple Canonical Canonical [Canonical]
56+ | Alias Text Canonical
57+ | Var Text
58+ | Anything
59+ | Literal L.Literal
53
60
54−list :: R.Position -> [Raw] -> Raw
55−list end patterns =
56− case patterns of
57− [] ->
58− A.at end end (Ctor (Var.Raw "[]") [])
59
61
60− pattern@(A.A (R.Region start _) _) : rest ->
61− A.at start end (Ctor (Var.Raw "::") [pattern, list end rest])
62
62
63+-- FIND VARIABLES
63
64
64−tuple :: [Raw] -> Raw'
65−tuple patterns =
66− let
67− name =
68− Help.makeTuple (length patterns)
69− in
70− Ctor (Var.Raw name) patterns
71
65
66+boundVars :: Raw -> [A.Located Text]
67+boundVars (A.A region pattern) =
68+ case pattern of
69+ RVar name ->
70+ [ A.A region name ]
72
71
72+ RAlias name realPattern ->
73+ A.A region name : boundVars realPattern
73
74
74−-- FIND VARIABLES
75+ RCtor _ _ patterns ->
76+ concatMap boundVars patterns
75
77
78+ RRecord fields ->
79+ map (A.A region) fields
76
80
77−boundVars :: Pattern ann var -> [A.Annotated ann Text]
81+ RUnit ->
78−boundVars (A.A ann pattern) =
82+ []
79− case pattern of
80− Var x ->
81− [A.A ann x]
82
83
83− Alias name realPattern ->
84+ RTuple a b cs ->
84− A.A ann name : boundVars realPattern
85+ concatMap boundVars (a:b:cs)
85
86
86− Ctor _ patterns ->
87+ RList xs ->
87− concatMap boundVars patterns
88+ concatMap boundVars xs
88
89
89− Record fields ->
90+ RCons a b ->
90− map (A.A ann) fields
91+ boundVars a ++ boundVars b
91
92
92− Anything ->
93+ RAnything ->
93 []
94 []
94
95
95− Literal _ ->
96+ RLiteral _ ->
96 []
97 []
97
98
98
99
99−member :: Text -> Pattern ann var -> Bool
100+member :: Text -> Raw -> Bool
100member name pattern =
101member name pattern =
101 elem name (map A.drop (boundVars pattern))
102 elem name (map A.drop (boundVars pattern))
102
103
103
104
104−boundVarSet :: Pattern ann var -> Set.Set Text
105+boundVarSet :: Raw -> Set.Set Text
105boundVarSet pattern =
106boundVarSet pattern =
106 Set.fromList (map A.drop (boundVars pattern))
107 Set.fromList (map A.drop (boundVars pattern))
107
108
108
109
109−boundVarList :: Pattern ann var -> [Text]
110+boundVarList :: Raw -> [Text]
110boundVarList pattern =
111boundVarList pattern =
111 Set.toList (boundVarSet pattern)
112 Set.toList (boundVarSet pattern)
112−
113−
114−
115−-- TO BUILDER
116−
117−
118−toString :: Canonical -> String
119−toString var =
120− LazyText.unpack (toLazyText (toBuilder False var))
121−
122−
123−toText :: Canonical -> Text
124−toText var =
125− LazyText.toStrict (toLazyText (toBuilder False var))
126−
127−
128−toBuilder :: Bool -> Canonical -> Builder
129−toBuilder needsParens (A.A _ pattern) =
130− case pattern of
131− Var name ->
132− fromText name
133−
134− Ctor name [] ->
135− if Var.isTuple name then "()" else fromText (Var.toText name)
136−
137− Ctor name args ->
138− if Var.isTuple name then
139− "( " <> mconcat (List.intersperse ", " (map (toBuilder False) args)) <> " )"
140− else
141− parensIf needsParens $
142− fromText (Var.toText name) <> mconcat (map (\arg -> " " <> toBuilder True arg) args)
143−
144− Record fields ->
145− "{" <> mconcat (List.intersperse "," (map fromText fields)) <> "}"
146−
147− Alias alias subPattern ->
148− parensIf needsParens $
149− toBuilder False subPattern <> " as " <> fromText alias
150−
151− Anything ->
152− "_"
153−
154− Literal literal ->
155− L.toBuilder literal
156−
157−
158−parensIf :: Bool -> Builder -> Builder
159−parensIf needsParens builder =
160− if needsParens then "(" <> builder <> ")" else builder
src/AST/Type.hs+32−30
@@ -6,7 +6,7 @@ module AST.Type
6 , Super(..)
6 , Super(..)
7 , deepDealias, iteratedDealias, dealias
7 , deepDealias, iteratedDealias, dealias
8 , collectLambdas
8 , collectLambdas
9− , tuple, cmd, sub
9+ , cmd, sub
10 )
10 )
11 where
11 where
12
12
@@ -16,7 +16,6 @@ import Data.Binary
16import qualified Data.Map as Map
16import qualified Data.Map as Map
17import Data.Text (Text)
17import Data.Text (Text)
18
18
19−import qualified AST.Helpers as Help
20import qualified AST.Module.Name as ModuleName
19import qualified AST.Module.Name as ModuleName
21import qualified AST.Variable as Var
20import qualified AST.Variable as Var
22import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
@@ -34,8 +33,10 @@ type Raw =
34data Raw'
33data Raw'
35 = RLambda Raw Raw
34 = RLambda Raw Raw
36 | RVar Text
35 | RVar Text
37− | RType (A.Located Var.Raw) [Raw]
36+ | RType R.Region (Maybe Text) Text [Raw]
38 | RRecord [(A.Located Text, Raw)] (Maybe Raw)
37 | RRecord [(A.Located Text, Raw)] (Maybe Raw)
38+ | RUnit
39+ | RTuple Raw Raw [Raw]
39
40
40
41
41data Canonical
42data Canonical
@@ -43,6 +44,8 @@ data Canonical
43 | Var Text
44 | Var Text
44 | Type Var.Canonical [Canonical]
45 | Type Var.Canonical [Canonical]
45 | Record [(Text, Canonical)] (Maybe Canonical)
46 | Record [(Text, Canonical)] (Maybe Canonical)
47+ | Unit
48+ | Tuple Canonical Canonical [Canonical]
46 | Aliased Var.Canonical [(Text, Canonical)] (Aliased Canonical)
49 | Aliased Var.Canonical [(Text, Canonical)] (Aliased Canonical)
47 deriving (Eq, Ord)
50 deriving (Eq, Ord)
48
51
@@ -65,15 +68,6 @@ data Super
65-- CONSTRUCT USEFUL TYPES
68-- CONSTRUCT USEFUL TYPES
66
69
67
70
68−tuple :: R.Region -> [Raw] -> Raw
69−tuple region types =
70− let
71− name =
72− Var.Raw (Help.makeTuple (length types))
73− in
74− A.A region (RType (A.A region name) types)
75−
76−
77cmd :: ModuleName.Canonical -> Text -> Canonical
71cmd :: ModuleName.Canonical -> Text -> Canonical
78cmd =
72cmd =
79 effect Var.cmd
73 effect Var.cmd
@@ -113,6 +107,12 @@ deepDealias tipe =
113 Type name args ->
107 Type name args ->
114 Type name (map deepDealias args)
108 Type name (map deepDealias args)
115
109
110+ Unit ->
111+ Unit
112+
113+ Tuple a b cs ->
114+ Tuple (deepDealias a) (deepDealias b) (map deepDealias cs)
115+
116
116
117iteratedDealias :: Canonical -> Canonical
117iteratedDealias :: Canonical -> Canonical
118iteratedDealias tipe =
118iteratedDealias tipe =
@@ -156,6 +156,12 @@ dealiasHelp typeTable tipe =
156 Type name args ->
156 Type name args ->
157 Type name (map go args)
157 Type name (map go args)
158
158
159+ Unit ->
160+ Unit
161+
162+ Tuple a b cs ->
163+ Tuple (go a) (go b) (map go cs)
164+
159
165
160
166
161-- COLLECT LAMBDAS
167-- COLLECT LAMBDAS
@@ -178,29 +184,23 @@ collectLambdas tipe =
178instance Binary Canonical where
184instance Binary Canonical where
179 put tipe =
185 put tipe =
180 case tipe of
186 case tipe of
181− Lambda t1 t2 ->
182− putWord8 0 >> put t1 >> put t2
187+ Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2
183−
184− Var x ->
185− putWord8 1 >> put x
188+ Var x -> putWord8 1 >> put x
186−
187− Record fs ext ->
188− putWord8 2 >> put fs >> put ext
189+ Record fs ext -> putWord8 2 >> put fs >> put ext
189−
190+ Unit -> putWord8 3
190− Aliased var args t ->
191+ Tuple a b cs -> putWord8 4 >> put a >> put b >> put cs
191− putWord8 3 >> put var >> put args >> put t
192+ Aliased var args t -> putWord8 5 >> put var >> put args >> put t
192−
193− Type name ts ->
193+ Type name ts ->
194 let
194 let
195 potentialWord =
195 potentialWord =
196− length ts + 5
196+ length ts + 7
197 in
197 in
198 if potentialWord <= fromIntegral (maxBound :: Word8) then
198 if potentialWord <= fromIntegral (maxBound :: Word8) then
199 do putWord8 (fromIntegral potentialWord)
199 do putWord8 (fromIntegral potentialWord)
200 put name
200 put name
201 mapM_ put ts
201 mapM_ put ts
202 else
202 else
203− putWord8 4 >> put name >> put ts
203+ putWord8 6 >> put name >> put ts
204
204
205 get =
205 get =
206 do word <- getWord8
206 do word <- getWord8
@@ -208,9 +208,11 @@ instance Binary Canonical where
208 0 -> liftM2 Lambda get get
208 0 -> liftM2 Lambda get get
209 1 -> liftM Var get
209 1 -> liftM Var get
210 2 -> liftM2 Record get get
210 2 -> liftM2 Record get get
211+ 3 -> return Unit
212+ 4 -> liftM3 Tuple get get get
211− 3 -> liftM3 Aliased get get get
213+ 5 -> liftM3 Aliased get get get
212− 4 -> liftM2 Type get get
214+ 6 -> liftM2 Type get get
213− n -> liftM2 Type get (replicateM (fromIntegral (n - 5)) get)
215+ n -> liftM2 Type get (replicateM (fromIntegral (n - 7)) get)
214
216
215
217
216instance Binary t => Binary (Aliased t) where
218instance Binary t => Binary (Aliased t) where