git.iko.soy/elk
on cb3a2fa help sign in
elk/src/AST/Expression/General.hs
306 lines 9.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
3{-| The Abstract Syntax Tree (AST) for expressions comes in a couple formats.
4The first is the fully general version and is labeled with a prime (Expr').
5The others are specialized versions of the AST that represent specific phases
6of the compilation process. I expect there to be more phases as we begin to
7enrich the AST with more information.
8-}
9module AST.Expression.General where
11import Text.PrettyPrint as P
13import qualified AST.Helpers as Help
14import qualified AST.Literal as Literal
15import qualified AST.Pattern as Pattern
16import qualified AST.Type as Type
17import qualified AST.Variable as Var
18import qualified Reporting.Annotation as A
19import qualified Reporting.Crash as Crash
20import qualified Reporting.PrettyPrint as P
23---- GENERAL AST ----
25{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
26"type holes" that allow us to enrich the AST with additional information as we
27move through the compilation process. The type holes are used to represent:
29 ann: Annotations for arbitrary expressions. Allows you to add information
30 to the AST like position in source code or inferred types.
32 def: Definition style. The source syntax separates type annotations and
33 definitions, but after parsing we check that they are well formed and
34 collapse them.
36 var: Representation of variables. Starts as strings, but is later enriched
37 with information about what module a variable came from.
39-}
40type Expr annotation definition variable tipe =
41 A.Annotated annotation (Expr' annotation definition variable tipe)
44data Expr' ann def var typ
45 = Literal Literal.Literal
46 | Var var
47 | Range (Expr ann def var typ) (Expr ann def var typ)
48 | ExplicitList [Expr ann def var typ]
49 | Binop var (Expr ann def var typ) (Expr ann def var typ)
50 | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)
51 | App (Expr ann def var typ) (Expr ann def var typ)
52 | MultiIf [(Expr ann def var typ, Expr ann def var typ)] (Expr ann def var typ)
53 | Let [def] (Expr ann def var typ)
54 | Case (Expr ann def var typ) [(Pattern.Pattern ann var, Expr ann def var typ)]
55 | Data String [Expr ann def var typ]
56 | Access (Expr ann def var typ) String
57 | Remove (Expr ann def var typ) String
58 | Insert (Expr ann def var typ) String (Expr ann def var typ)
59 | Modify (Expr ann def var typ) [(String, Expr ann def var typ)]
60 | Record [(String, Expr ann def var typ)]
61 -- for type checking and code gen only
62 | Port (PortImpl (Expr ann def var typ) typ)
63 | GLShader String String Literal.GLShaderTipe
64 | Crash Crash.Details
65 deriving (Show)
68-- PORTS
70data PortImpl expr tipe
71 = In String (Type.Port tipe)
72 | Out String expr (Type.Port tipe)
73 | Task String expr (Type.Port tipe)
74 deriving (Show)
77portName :: PortImpl expr tipe -> String
78portName impl =
79 case impl of
80 In name _ -> name
81 Out name _ _ -> name
82 Task name _ _ -> name
85---- UTILITIES ----
87rawVar :: String -> Expr' ann def Var.Raw typ
88rawVar x =
89 Var (Var.Raw x)
92localVar :: String -> Expr' ann def Var.Canonical typ
93localVar x =
94 Var (Var.Canonical Var.Local x)
97tuple :: [Expr ann def var typ] -> Expr' ann def var typ
98tuple expressions =
99 Data ("_Tuple" ++ show (length expressions)) expressions
102saveEnvName :: String
103saveEnvName =
104 "_save_the_environment!!!"
107dummyLet :: (P.Pretty def) => [def] -> Expr ann def Var.Canonical typ
108dummyLet defs =
109 let body =
110 A.A undefined (Var (Var.builtin saveEnvName))
111 in
112 A.A undefined (Let defs body)
115-- PRETTY PRINTING
117instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where
118 pretty dealiaser needsParens expression =
119 case expression of
120 Literal literal ->
121 P.pretty dealiaser needsParens literal
123 Var x ->
124 P.pretty dealiaser needsParens x
126 Range lowExpr highExpr ->
127 P.brackets $
128 P.pretty dealiaser False lowExpr
129 <> P.text ".."
130 <> P.pretty dealiaser False highExpr
132 ExplicitList elements ->
133 P.brackets (P.commaCat (map (P.pretty dealiaser False) elements))
135 Binop op (A.A _ (Literal (Literal.IntNum 0))) expr
136 | Var.toString op == "-" ->
137 P.text "-" <> P.pretty dealiaser True expr
139 Binop op leftExpr rightExpr ->
140 P.parensIf needsParens $
141 P.hang
142 (P.pretty dealiaser True leftExpr)
143 2
144 (P.text op'' <+> P.pretty dealiaser True rightExpr)
145 where
146 op' = Var.toString op
147 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
149 Lambda pattern expr ->
150 P.parensIf needsParens $
151 P.text "\\" <> args <+> P.text "->" <+> P.pretty dealiaser False body
152 where
153 (patterns, body) =
154 collectLambdas expr
156 args =
157 P.sep (map (P.pretty dealiaser True) (pattern : patterns))
159 App expr arg ->
160 P.parensIf needsParens $
161 P.hang func 2 (P.sep args)
162 where
163 func:args =
164 map (P.pretty dealiaser True) (collectApps expr ++ [arg])
166 MultiIf [(condition, thenBranch)] elseBranch ->
167 P.parensIf needsParens $ P.sep $
168 [ P.text "if" <+> P.pretty dealiaser False condition <+> P.text "then"
169 , P.nest 4 (P.pretty dealiaser False thenBranch)
170 , P.text "else"
171 , P.nest 4 (P.pretty dealiaser False elseBranch)
172 ]
174 MultiIf branches finally ->
175 P.parensIf needsParens $
176 P.text "if" $$ nest 3 (vcat $ map iff branches ++ [final])
177 where
178 iff (condition, branch) =
179 P.text "|" <+>
180 P.hang
181 (P.pretty dealiaser False condition <+> P.text "->")
182 2
183 (P.pretty dealiaser False branch)
185 final =
186 P.hang (P.text "| True -> ") 2 (P.pretty dealiaser False finally)
188 Let defs body ->
189 P.parensIf needsParens $
190 P.sep
191 [ P.hang
192 (P.text "let")
193 4
194 (P.vcat (map (P.pretty dealiaser False) defs))
195 , P.text "in" <+> P.pretty dealiaser False body
196 ]
198 Case expr branches ->
199 P.parensIf needsParens $
200 P.hang pexpr 2 (P.vcat (map pretty' branches))
201 where
202 pexpr =
203 P.text "case" <+> P.pretty dealiaser False expr <+> P.text "of"
205 pretty' (pattern, branch) =
206 P.pretty dealiaser False pattern
207 <+> P.text "->"
208 <+> P.pretty dealiaser False branch
210 Data "::" [hd,tl] ->
211 P.parensIf needsParens $
212 P.pretty dealiaser True hd <+> P.text "::" <+> P.pretty dealiaser True tl
214 Data "[]" [] ->
215 P.text "[]"
217 Data name exprs ->
218 if Help.isTuple name
219 then
220 P.parens (P.commaCat (map (P.pretty dealiaser False) exprs))
221 else
222 P.parensIf (needsParens && not (null exprs)) $
223 P.hang
224 (P.text name)
225 2
226 (P.sep (map (P.pretty dealiaser True) exprs))
228 Access record field ->
229 P.pretty dealiaser True record <> P.text "." <> P.text field
231 Remove record field ->
232 P.braces (P.pretty dealiaser False record <+> P.text "-" <+> P.text field)
234 Insert (A.A _ (Remove record oldField)) newField expr ->
235 P.braces $
236 P.hsep
237 [ P.pretty dealiaser False record
238 , P.text "-"
239 , P.text oldField
240 , P.text "|"
241 , P.text newField
242 , P.equals
243 , P.pretty dealiaser False expr
244 ]
246 Insert record field expr ->
247 P.braces $
248 P.pretty dealiaser False record
249 <+> P.text "|"
250 <+> P.text field
251 <+> P.equals
252 <+> P.pretty dealiaser False expr
254 Modify record fields ->
255 P.braces $
256 P.hang
257 (P.pretty dealiaser False record <+> P.text "|")
258 4
259 (P.commaSep $ map prettyField fields)
260 where
261 prettyField (field, expr) =
262 P.text field <+> P.text "<-" <+> P.pretty dealiaser False expr
264 Record fields ->
265 P.sep
266 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fields))
267 , P.rbrace
268 ]
269 where
270 field (name, expr) =
271 P.text name <+> P.equals <+> P.pretty dealiaser False expr
273 GLShader _ _ _ ->
274 P.text "[glsl| ... |]"
276 Port portImpl ->
277 P.pretty dealiaser needsParens portImpl
279 Crash details ->
280 P.text ("<crash:" ++ Crash.summary details ++ ">")
283instance P.Pretty (PortImpl expr tipe) where
284 pretty _ _ impl =
285 P.text ("<port:" ++ portName impl ++ ">")
288collectApps :: Expr ann def var typ -> [Expr ann def var typ]
289collectApps annExpr@(A.A _ expr) =
290 case expr of
291 App a b -> collectApps a ++ [b]
292 _ -> [annExpr]
295collectLambdas
296 :: Expr ann def var typ
297 -> ([Pattern.Pattern ann var], Expr ann def var typ)
298collectLambdas lexpr@(A.A _ expr) =
299 case expr of
300 Lambda pattern body ->
301 let
302 (ps, body') = collectLambdas body
303 in
304 (pattern : ps, body')
306 _ -> ([], lexpr)