git.iko.soy/elk
on 54dfb21 help sign in
elk/src/AST/Expression/General.hs
274 lines 8.4 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.PrettyPrint as P
22---- GENERAL AST ----
24{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
25"type holes" that allow us to enrich the AST with additional information as we
26move through the compilation process. The type holes are used to represent:
28 ann: Annotations for arbitrary expressions. Allows you to add information
29 to the AST like position in source code or inferred types.
31 def: Definition style. The source syntax separates type annotations and
32 definitions, but after parsing we check that they are well formed and
33 collapse them.
35 var: Representation of variables. Starts as strings, but is later enriched
36 with information about what module a variable came from.
38-}
39type Expr annotation definition variable tipe =
40 A.Annotated annotation (Expr' annotation definition variable tipe)
43data Expr' ann def var typ
44 = Literal Literal.Literal
45 | Var var
46 | Range (Expr ann def var typ) (Expr ann def var typ)
47 | ExplicitList [Expr ann def var typ]
48 | Binop var (Expr ann def var typ) (Expr ann def var typ)
49 | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)
50 | App (Expr ann def var typ) (Expr ann def var typ)
51 | If [(Expr ann def var typ, Expr ann def var typ)] (Expr ann def var typ)
52 | Let [def] (Expr ann def var typ)
53 | Case (Expr ann def var typ) [(Pattern.Pattern ann var, Expr ann def var typ)]
54 | Data String [Expr ann def var typ]
55 | Access (Expr ann def var typ) String
56 | Update (Expr ann def var typ) [(String, Expr ann def var typ)]
57 | Record [(String, Expr ann def var typ)]
58 -- for type checking and code gen only
59 | Port (PortImpl (Expr ann def var typ) typ)
60 | GLShader String String Literal.GLShaderTipe
61 deriving (Show)
64-- PORTS
66data PortImpl expr tipe
67 = In String (Type.Port tipe)
68 | Out String expr (Type.Port tipe)
69 | Task String expr (Type.Port tipe)
70 deriving (Eq, Show)
73portName :: PortImpl expr tipe -> String
74portName impl =
75 case impl of
76 In name _ -> name
77 Out name _ _ -> name
78 Task name _ _ -> name
81---- UTILITIES ----
83rawVar :: String -> Expr' ann def Var.Raw typ
84rawVar x =
85 Var (Var.Raw x)
88localVar :: String -> Expr' ann def Var.Canonical typ
89localVar x =
90 Var (Var.Canonical Var.Local x)
93tuple :: [Expr ann def var typ] -> Expr' ann def var typ
94tuple expressions =
95 Data ("_Tuple" ++ show (length expressions)) expressions
98saveEnvName :: String
99saveEnvName =
100 "_save_the_environment!!!"
103dummyLet :: (P.Pretty def) => [def] -> Expr ann def Var.Canonical typ
104dummyLet defs =
105 let body =
106 A.A undefined (Var (Var.builtin saveEnvName))
107 in
108 A.A undefined (Let defs body)
111-- PRETTY PRINTING
113instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where
114 pretty dealiaser needsParens expression =
115 case expression of
116 Literal literal ->
117 P.pretty dealiaser needsParens literal
119 Var x ->
120 P.pretty dealiaser needsParens x
122 Range lowExpr highExpr ->
123 P.brackets $
124 P.pretty dealiaser False lowExpr
125 <> P.text ".."
126 <> P.pretty dealiaser False highExpr
128 ExplicitList elements ->
129 P.brackets (P.commaCat (map (P.pretty dealiaser False) elements))
131 Binop op (A.A _ (Literal (Literal.IntNum 0))) expr
132 | Var.toString op == "-" ->
133 P.text "-" <> P.pretty dealiaser True expr
135 Binop op leftExpr rightExpr ->
136 P.parensIf needsParens $
137 P.hang
138 (P.pretty dealiaser True leftExpr)
139 2
140 (P.text op'' <+> P.pretty dealiaser True rightExpr)
141 where
142 op' = Var.toString op
143 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
145 Lambda pattern expr ->
146 P.parensIf needsParens $
147 P.text "\\" <> args <+> P.text "->" <+> P.pretty dealiaser False body
148 where
149 (patterns, body) =
150 collectLambdas expr
152 args =
153 P.sep (map (P.pretty dealiaser True) (pattern : patterns))
155 App expr arg ->
156 P.parensIf needsParens $
157 P.hang func 2 (P.sep args)
158 where
159 func:args =
160 map (P.pretty dealiaser True) (collectApps expr ++ [arg])
162 If branches finally ->
163 let
164 prettyFinally =
165 P.nest 4 (P.pretty dealiaser False finally)
167 prettyBranch (condition, thenBranch) (firstLine, rest) =
168 ( P.text "if" <+> P.pretty dealiaser False condition <+> P.text "then"
169 ,
170 [ P.nest 4 (P.pretty dealiaser False thenBranch)
171 , P.text "else" <+> firstLine
172 ]
173 ++ rest
174 )
175 in
176 P.parensIf needsParens $ P.sep $ uncurry (:) $
177 foldr
178 prettyBranch
179 ( P.empty, [prettyFinally] )
180 branches
182 Let defs body ->
183 P.parensIf needsParens $
184 P.sep
185 [ P.hang
186 (P.text "let")
187 4
188 (P.vcat (map (P.pretty dealiaser False) defs))
189 , P.text "in" <+> P.pretty dealiaser False body
190 ]
192 Case expr branches ->
193 P.parensIf needsParens $
194 P.hang pexpr 2 (P.vcat (map pretty' branches))
195 where
196 pexpr =
197 P.text "case" <+> P.pretty dealiaser False expr <+> P.text "of"
199 pretty' (pattern, branch) =
200 P.pretty dealiaser False pattern
201 <+> P.text "->"
202 <+> P.pretty dealiaser False branch
204 Data "::" [hd,tl] ->
205 P.parensIf needsParens $
206 P.pretty dealiaser True hd <+> P.text "::" <+> P.pretty dealiaser True tl
208 Data "[]" [] ->
209 P.text "[]"
211 Data name exprs ->
212 if Help.isTuple name
213 then
214 P.parens (P.commaCat (map (P.pretty dealiaser False) exprs))
215 else
216 P.parensIf (needsParens && not (null exprs)) $
217 P.hang
218 (P.text name)
219 2
220 (P.sep (map (P.pretty dealiaser True) exprs))
222 Access record field ->
223 P.pretty dealiaser True record <> P.text "." <> P.text field
225 Update record fields ->
226 P.braces $
227 P.hang
228 (P.pretty dealiaser False record <+> P.text "|")
229 4
230 (P.commaSep $ map prettyField fields)
231 where
232 prettyField (field, expr) =
233 P.text field <+> P.text "<-" <+> P.pretty dealiaser False expr
235 Record fields ->
236 P.sep
237 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fields))
238 , P.rbrace
239 ]
240 where
241 field (name, expr) =
242 P.text name <+> P.equals <+> P.pretty dealiaser False expr
244 GLShader _ _ _ ->
245 P.text "[glsl| ... |]"
247 Port portImpl ->
248 P.pretty dealiaser needsParens portImpl
251instance P.Pretty (PortImpl expr tipe) where
252 pretty _ _ impl =
253 P.text ("<port:" ++ portName impl ++ ">")
256collectApps :: Expr ann def var typ -> [Expr ann def var typ]
257collectApps annExpr@(A.A _ expr) =
258 case expr of
259 App a b -> collectApps a ++ [b]
260 _ -> [annExpr]
263collectLambdas
264 :: Expr ann def var typ
265 -> ([Pattern.Pattern ann var], Expr ann def var typ)
266collectLambdas lexpr@(A.A _ expr) =
267 case expr of
268 Lambda pattern body ->
269 let
270 (ps, body') = collectLambdas body
271 in
272 (pattern : ps, body')
274 _ -> ([], lexpr)