git.iko.soy/elk
on ac4e451 help sign in
elk/src/AST/Expression/General.hs
279 lines 8.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 | If [(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 | Update (Expr ann def var typ) [(String, Expr ann def var typ)]
58 | Record [(String, Expr ann def var typ)]
59 -- for type checking and code gen only
60 | Port (PortImpl (Expr ann def var typ) typ)
61 | GLShader String String Literal.GLShaderTipe
62 | Crash Crash.Details
63 deriving (Show)
66-- PORTS
68data PortImpl expr tipe
69 = In String (Type.Port tipe)
70 | Out String expr (Type.Port tipe)
71 | Task String expr (Type.Port tipe)
72 deriving (Show)
75portName :: PortImpl expr tipe -> String
76portName impl =
77 case impl of
78 In name _ -> name
79 Out name _ _ -> name
80 Task name _ _ -> name
83---- UTILITIES ----
85rawVar :: String -> Expr' ann def Var.Raw typ
86rawVar x =
87 Var (Var.Raw x)
90localVar :: String -> Expr' ann def Var.Canonical typ
91localVar x =
92 Var (Var.Canonical Var.Local x)
95tuple :: [Expr ann def var typ] -> Expr' ann def var typ
96tuple expressions =
97 Data ("_Tuple" ++ show (length expressions)) expressions
100saveEnvName :: String
101saveEnvName =
102 "_save_the_environment!!!"
105dummyLet :: (P.Pretty def) => [def] -> Expr ann def Var.Canonical typ
106dummyLet defs =
107 let body =
108 A.A undefined (Var (Var.builtin saveEnvName))
109 in
110 A.A undefined (Let defs body)
113-- PRETTY PRINTING
115instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where
116 pretty dealiaser needsParens expression =
117 case expression of
118 Literal literal ->
119 P.pretty dealiaser needsParens literal
121 Var x ->
122 P.pretty dealiaser needsParens x
124 Range lowExpr highExpr ->
125 P.brackets $
126 P.pretty dealiaser False lowExpr
127 <> P.text ".."
128 <> P.pretty dealiaser False highExpr
130 ExplicitList elements ->
131 P.brackets (P.commaCat (map (P.pretty dealiaser False) elements))
133 Binop op (A.A _ (Literal (Literal.IntNum 0))) expr
134 | Var.toString op == "-" ->
135 P.text "-" <> P.pretty dealiaser True expr
137 Binop op leftExpr rightExpr ->
138 P.parensIf needsParens $
139 P.hang
140 (P.pretty dealiaser True leftExpr)
141 2
142 (P.text op'' <+> P.pretty dealiaser True rightExpr)
143 where
144 op' = Var.toString op
145 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
147 Lambda pattern expr ->
148 P.parensIf needsParens $
149 P.text "\\" <> args <+> P.text "->" <+> P.pretty dealiaser False body
150 where
151 (patterns, body) =
152 collectLambdas expr
154 args =
155 P.sep (map (P.pretty dealiaser True) (pattern : patterns))
157 App expr arg ->
158 P.parensIf needsParens $
159 P.hang func 2 (P.sep args)
160 where
161 func:args =
162 map (P.pretty dealiaser True) (collectApps expr ++ [arg])
164 If branches finally ->
165 let
166 prettyFinally =
167 P.nest 4 (P.pretty dealiaser False finally)
169 prettyBranch (condition, thenBranch) (firstLine, rest) =
170 ( P.text "if" <+> P.pretty dealiaser False condition <+> P.text "then"
171 ,
172 [ P.nest 4 (P.pretty dealiaser False thenBranch)
173 , P.text "else" <+> firstLine
174 ]
175 ++ rest
176 )
177 in
178 P.parensIf needsParens $ P.sep $ uncurry (:) $
179 foldr
180 prettyBranch
181 ( P.empty, [prettyFinally] )
182 branches
184 Let defs body ->
185 P.parensIf needsParens $
186 P.sep
187 [ P.hang
188 (P.text "let")
189 4
190 (P.vcat (map (P.pretty dealiaser False) defs))
191 , P.text "in" <+> P.pretty dealiaser False body
192 ]
194 Case expr branches ->
195 P.parensIf needsParens $
196 P.hang pexpr 2 (P.vcat (map pretty' branches))
197 where
198 pexpr =
199 P.text "case" <+> P.pretty dealiaser False expr <+> P.text "of"
201 pretty' (pattern, branch) =
202 P.pretty dealiaser False pattern
203 <+> P.text "->"
204 <+> P.pretty dealiaser False branch
206 Data "::" [hd,tl] ->
207 P.parensIf needsParens $
208 P.pretty dealiaser True hd <+> P.text "::" <+> P.pretty dealiaser True tl
210 Data "[]" [] ->
211 P.text "[]"
213 Data name exprs ->
214 if Help.isTuple name
215 then
216 P.parens (P.commaCat (map (P.pretty dealiaser False) exprs))
217 else
218 P.parensIf (needsParens && not (null exprs)) $
219 P.hang
220 (P.text name)
221 2
222 (P.sep (map (P.pretty dealiaser True) exprs))
224 Access record field ->
225 P.pretty dealiaser True record <> P.text "." <> P.text field
227 Update record fields ->
228 P.braces $
229 P.hang
230 (P.pretty dealiaser False record <+> P.text "|")
231 4
232 (P.commaSep $ map prettyField fields)
233 where
234 prettyField (field, expr) =
235 P.text field <+> P.text "<-" <+> P.pretty dealiaser False expr
237 Record fields ->
238 P.sep
239 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fields))
240 , P.rbrace
241 ]
242 where
243 field (name, expr) =
244 P.text name <+> P.equals <+> P.pretty dealiaser False expr
246 GLShader _ _ _ ->
247 P.text "[glsl| ... |]"
249 Port portImpl ->
250 P.pretty dealiaser needsParens portImpl
252 Crash details ->
253 P.text ("<crash:" ++ Crash.summary details ++ ">")
256instance P.Pretty (PortImpl expr tipe) where
257 pretty _ _ impl =
258 P.text ("<port:" ++ portName impl ++ ">")
261collectApps :: Expr ann def var typ -> [Expr ann def var typ]
262collectApps annExpr@(A.A _ expr) =
263 case expr of
264 App a b -> collectApps a ++ [b]
265 _ -> [annExpr]
268collectLambdas
269 :: Expr ann def var typ
270 -> ([Pattern.Pattern ann var], Expr ann def var typ)
271collectLambdas lexpr@(A.A _ expr) =
272 case expr of
273 Lambda pattern body ->
274 let
275 (ps, body') = collectLambdas body
276 in
277 (pattern : ps, body')
279 _ -> ([], lexpr)