git.iko.soy/elk
on 90243ae help sign in
elk/src/AST/Expression/General.hs
305 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)
67-- PORTS
69data PortImpl expr tipe
70 = In String (Type.Port tipe)
71 | Out String expr (Type.Port tipe)
72 | Task String expr (Type.Port tipe)
73 deriving (Show)
76portName :: PortImpl expr tipe -> String
77portName impl =
78 case impl of
79 In name _ -> name
80 Out name _ _ -> name
81 Task name _ _ -> name
84---- UTILITIES ----
86rawVar :: String -> Expr' ann def Var.Raw typ
87rawVar x =
88 Var (Var.Raw x)
91localVar :: String -> Expr' ann def Var.Canonical typ
92localVar x =
93 Var (Var.Canonical Var.Local x)
96tuple :: [Expr ann def var typ] -> Expr' ann def var typ
97tuple expressions =
98 Data ("_Tuple" ++ show (length expressions)) expressions
101saveEnvName :: String
102saveEnvName =
103 "_save_the_environment!!!"
106dummyLet :: (P.Pretty def) => [def] -> Expr ann def Var.Canonical typ
107dummyLet defs =
108 let body =
109 A.A undefined (Var (Var.builtin saveEnvName))
110 in
111 A.A undefined (Let defs body)
114-- PRETTY PRINTING
116instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where
117 pretty dealiaser needsParens expression =
118 case expression of
119 Literal literal ->
120 P.pretty dealiaser needsParens literal
122 Var x ->
123 P.pretty dealiaser needsParens x
125 Range lowExpr highExpr ->
126 P.brackets $
127 P.pretty dealiaser False lowExpr
128 <> P.text ".."
129 <> P.pretty dealiaser False highExpr
131 ExplicitList elements ->
132 P.brackets (P.commaCat (map (P.pretty dealiaser False) elements))
134 Binop op (A.A _ (Literal (Literal.IntNum 0))) expr
135 | Var.toString op == "-" ->
136 P.text "-" <> P.pretty dealiaser True expr
138 Binop op leftExpr rightExpr ->
139 P.parensIf needsParens $
140 P.hang
141 (P.pretty dealiaser True leftExpr)
142 2
143 (P.text op'' <+> P.pretty dealiaser True rightExpr)
144 where
145 op' = Var.toString op
146 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
148 Lambda pattern expr ->
149 P.parensIf needsParens $
150 P.text "\\" <> args <+> P.text "->" <+> P.pretty dealiaser False body
151 where
152 (patterns, body) =
153 collectLambdas expr
155 args =
156 P.sep (map (P.pretty dealiaser True) (pattern : patterns))
158 App expr arg ->
159 P.parensIf needsParens $
160 P.hang func 2 (P.sep args)
161 where
162 func:args =
163 map (P.pretty dealiaser True) (collectApps expr ++ [arg])
165 MultiIf [(condition, thenBranch)] elseBranch ->
166 P.parensIf needsParens $ P.sep $
167 [ P.text "if" <+> P.pretty dealiaser False condition <+> P.text "then"
168 , P.nest 4 (P.pretty dealiaser False thenBranch)
169 , P.text "else"
170 , P.nest 4 (P.pretty dealiaser False elseBranch)
171 ]
173 MultiIf branches finally ->
174 P.parensIf needsParens $
175 P.text "if" $$ nest 3 (vcat $ map iff branches ++ [final])
176 where
177 iff (condition, branch) =
178 P.text "|" <+>
179 P.hang
180 (P.pretty dealiaser False condition <+> P.text "->")
181 2
182 (P.pretty dealiaser False branch)
184 final =
185 P.hang (P.text "| True -> ") 2 (P.pretty dealiaser False finally)
187 Let defs body ->
188 P.parensIf needsParens $
189 P.sep
190 [ P.hang
191 (P.text "let")
192 4
193 (P.vcat (map (P.pretty dealiaser False) defs))
194 , P.text "in" <+> P.pretty dealiaser False body
195 ]
197 Case expr branches ->
198 P.parensIf needsParens $
199 P.hang pexpr 2 (P.vcat (map pretty' branches))
200 where
201 pexpr =
202 P.text "case" <+> P.pretty dealiaser False expr <+> P.text "of"
204 pretty' (pattern, branch) =
205 P.pretty dealiaser False pattern
206 <+> P.text "->"
207 <+> P.pretty dealiaser False branch
209 Data "::" [hd,tl] ->
210 P.parensIf needsParens $
211 P.pretty dealiaser True hd <+> P.text "::" <+> P.pretty dealiaser True tl
213 Data "[]" [] ->
214 P.text "[]"
216 Data name exprs ->
217 if Help.isTuple name
218 then
219 P.parens (P.commaCat (map (P.pretty dealiaser False) exprs))
220 else
221 P.parensIf (needsParens && not (null exprs)) $
222 P.hang
223 (P.text name)
224 2
225 (P.sep (map (P.pretty dealiaser True) exprs))
227 Access record field ->
228 P.pretty dealiaser True record <> P.text "." <> P.text field
230 Remove record field ->
231 P.braces (P.pretty dealiaser False record <+> P.text "-" <+> P.text field)
233 Insert (A.A _ (Remove record oldField)) newField expr ->
234 P.braces $
235 P.hsep
236 [ P.pretty dealiaser False record
237 , P.text "-"
238 , P.text oldField
239 , P.text "|"
240 , P.text newField
241 , P.equals
242 , P.pretty dealiaser False expr
243 ]
245 Insert record field expr ->
246 P.braces $
247 P.pretty dealiaser False record
248 <+> P.text "|"
249 <+> P.text field
250 <+> P.equals
251 <+> P.pretty dealiaser False expr
253 Modify record fields ->
254 P.braces $
255 P.hang
256 (P.pretty dealiaser False record <+> P.text "|")
257 4
258 (P.commaSep $ map prettyField fields)
259 where
260 prettyField (field, expr) =
261 P.text field <+> P.text "<-" <+> P.pretty dealiaser False expr
263 Record fields ->
264 P.sep
265 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fields))
266 , P.rbrace
267 ]
268 where
269 field (name, expr) =
270 P.text name <+> P.equals <+> P.pretty dealiaser False expr
272 GLShader _ _ _ ->
273 P.text "[glsl| ... |]"
275 Port portImpl ->
276 P.pretty dealiaser needsParens portImpl
278 Crash details ->
279 P.text ("<crash:" ++ Crash.summary details ++ ">")
282instance P.Pretty (PortImpl expr tipe) where
283 pretty _ _ impl =
284 P.text ("<port:" ++ portName impl ++ ">")
287collectApps :: Expr ann def var typ -> [Expr ann def var typ]
288collectApps annExpr@(A.A _ expr) =
289 case expr of
290 App a b -> collectApps a ++ [b]
291 _ -> [annExpr]
294collectLambdas
295 :: Expr ann def var typ
296 -> ([Pattern.Pattern ann var], Expr ann def var typ)
297collectLambdas lexpr@(A.A _ expr) =
298 case expr of
299 Lambda pattern body ->
300 let
301 (ps, body') = collectLambdas body
302 in
303 (pattern : ps, body')
305 _ -> ([], lexpr)