git.iko.soy/elk
on 9b0c310 help sign in
elk/src/AST/Expression/General.hs
288 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.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 | MultiIf [(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 | Remove (Expr ann def var typ) String
57 | Insert (Expr ann def var typ) String (Expr ann def var typ)
58 | Modify (Expr ann def var typ) [(String, Expr ann def var typ)]
59 | Record [(String, Expr ann def var typ)]
60 -- for type checking and code gen only
61 | Port (PortImpl (Expr ann def var typ) typ)
62 | GLShader String String Literal.GLShaderTipe
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 needsParens expression =
117 case expression of
118 Literal literal ->
119 P.pretty needsParens literal
121 Var x ->
122 P.pretty needsParens x
124 Range lowExpr highExpr ->
125 P.brackets $
126 P.pretty False lowExpr
127 <> P.text ".."
128 <> P.pretty False highExpr
130 ExplicitList elements ->
131 P.brackets (P.commaCat (map (P.pretty False) elements))
133 Binop op (A.A _ (Literal (Literal.IntNum 0))) expr
134 | Var.toString op == "-" ->
135 P.text "-" <> P.pretty True expr
137 Binop op leftExpr rightExpr ->
138 P.parensIf needsParens $
139 P.hang
140 (P.pretty True leftExpr)
141 2
142 (P.text op'' <+> P.pretty 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 False body
150 where
151 (patterns, body) =
152 collectLambdas expr
154 args =
155 P.sep (map (P.pretty 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 True) (collectApps expr ++ [arg])
164 MultiIf branches ->
165 P.parensIf needsParens $
166 P.text "if" $$ nest 3 (vcat $ map iff branches)
167 where
168 iff (condition, branch) =
169 P.text "|" <+>
170 P.hang
171 (P.pretty False condition <+> P.text "->")
172 2
173 (P.pretty False branch)
175 Let defs body ->
176 P.parensIf needsParens $
177 P.sep
178 [ P.hang
179 (P.text "let")
180 4
181 (P.vcat (map (P.pretty False) defs))
182 , P.text "in" <+> P.pretty False body
183 ]
185 Case expr branches ->
186 P.parensIf needsParens $
187 P.hang pexpr 2 (P.vcat (map pretty' branches))
188 where
189 pexpr =
190 P.text "case" <+> P.pretty False expr <+> P.text "of"
192 pretty' (pattern, branch) =
193 P.pretty False pattern
194 <+> P.text "->"
195 <+> P.pretty False branch
197 Data "::" [hd,tl] ->
198 P.parensIf needsParens $
199 P.pretty True hd <+> P.text "::" <+> P.pretty True tl
201 Data "[]" [] ->
202 P.text "[]"
204 Data name exprs ->
205 if Help.isTuple name
206 then
207 P.parens (P.commaCat (map (P.pretty False) exprs))
208 else
209 P.parensIf (needsParens && not (null exprs)) $
210 P.hang
211 (P.text name)
212 2
213 (P.sep (map (P.pretty True) exprs))
215 Access record field ->
216 P.pretty True record <> P.text "." <> P.text field
218 Remove record field ->
219 P.braces (P.pretty False record <+> P.text "-" <+> P.text field)
221 Insert (A.A _ (Remove record oldField)) newField expr ->
222 P.braces $
223 P.hsep
224 [ P.pretty False record
225 , P.text "-"
226 , P.text oldField
227 , P.text "|"
228 , P.text newField
229 , P.equals
230 , P.pretty False expr
231 ]
233 Insert record field expr ->
234 P.braces $
235 P.pretty False record
236 <+> P.text "|"
237 <+> P.text field
238 <+> P.equals
239 <+> P.pretty False expr
241 Modify record fields ->
242 P.braces $
243 P.hang
244 (P.pretty False record <+> P.text "|")
245 4
246 (P.commaSep $ map prettyField fields)
247 where
248 prettyField (field, expr) =
249 P.text field <+> P.text "<-" <+> P.pretty False expr
251 Record fields ->
252 P.sep
253 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fields))
254 , P.rbrace
255 ]
256 where
257 field (name, expr) =
258 P.text name <+> P.equals <+> P.pretty False expr
260 GLShader _ _ _ ->
261 P.text "[glsl| ... |]"
263 Port portImpl ->
264 P.pretty needsParens portImpl
267instance P.Pretty (PortImpl expr tipe) where
268 pretty _ impl =
269 P.text ("<port:" ++ portName impl ++ ">")
272collectApps :: Expr ann def var typ -> [Expr ann def var typ]
273collectApps annExpr@(A.A _ expr) =
274 case expr of
275 App a b -> collectApps a ++ [b]
276 _ -> [annExpr]
279collectLambdas
280 :: Expr ann def var typ
281 -> ([Pattern.Pattern ann var], Expr ann def var typ)
282collectLambdas lexpr@(A.A _ expr) =
283 case expr of
284 Lambda pattern body ->
285 let (ps, body') = collectLambdas body
286 in (pattern : ps, body')
288 _ -> ([], lexpr)