git.iko.soy/elk
on 501c607 help sign in
elk/src/AST/Expression/General.hs
238 lines 7.2 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 AST.PrettyPrint
12import Text.PrettyPrint as P
13import AST.Type (Type)
15import qualified AST.Annotation as Annotation
16import qualified AST.Helpers as Help
17import qualified AST.Literal as Literal
18import qualified AST.Pattern as Pattern
19import qualified AST.Variable as Var
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 =
40 Annotation.Annotated annotation (Expr' annotation definition variable)
43data Expr' ann def var
44 = Literal Literal.Literal
45 | Var var
46 | Range (Expr ann def var) (Expr ann def var)
47 | ExplicitList [Expr ann def var]
48 | Binop var (Expr ann def var) (Expr ann def var)
49 | Lambda (Pattern.Pattern var) (Expr ann def var)
50 | App (Expr ann def var) (Expr ann def var)
51 | MultiIf [(Expr ann def var,Expr ann def var)]
52 | Let [def] (Expr ann def var)
53 | Case (Expr ann def var) [(Pattern.Pattern var, Expr ann def var)]
54 | Data String [Expr ann def var]
55 | Access (Expr ann def var) String
56 | Remove (Expr ann def var) String
57 | Insert (Expr ann def var) String (Expr ann def var)
58 | Modify (Expr ann def var) [(String, Expr ann def var)]
59 | Record [(String, Expr ann def var)]
60 -- for type checking and code gen only
61 | Input String (Type var)
62 | Output String (Type var) (Expr ann def var)
63 | Loopback String (Type var) (Maybe (Expr ann def var))
64 | GLShader String String Literal.GLShaderTipe
65 deriving (Show)
68---- UTILITIES ----
70rawVar :: String -> Expr' ann def Var.Raw
71rawVar x =
72 Var (Var.Raw x)
75localVar :: String -> Expr' ann def Var.Canonical
76localVar x =
77 Var (Var.Canonical Var.Local x)
80tuple :: [Expr ann def var] -> Expr' ann def var
81tuple expressions =
82 Data ("_Tuple" ++ show (length expressions)) expressions
85saveEnvName :: String
86saveEnvName =
87 "_save_the_environment!!!"
90dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical
91dummyLet defs =
92 Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName))
95instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where
96 pretty expr =
97 case expr of
98 Literal lit ->
99 pretty lit
101 Var x ->
102 pretty x
104 Range e1 e2 ->
105 P.brackets (pretty e1 <> P.text ".." <> pretty e2)
107 ExplicitList es ->
108 P.brackets (commaCat (map pretty es))
110 Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) e
111 | Var.toString op == "-" ->
112 P.text "-" <> prettyParens e
114 Binop op e1 e2 ->
115 P.hang (prettyParens e1) 2 (P.text op'' <+> prettyParens e2)
116 where
117 op' = Var.toString op
118 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
120 Lambda p e ->
121 P.text "\\" <> args <+> P.text "->" <+> pretty body
122 where
123 (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)
124 args = P.sep (map Pattern.prettyParens ps)
126 App _ _ ->
127 P.hang func 2 (P.sep args)
128 where
129 func:args =
130 map prettyParens (collectApps (Annotation.A undefined expr))
132 MultiIf branches ->
133 P.text "if" $$ nest 3 (vcat $ map iff branches)
134 where
135 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
137 Let defs e ->
138 P.sep
139 [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
140 , P.text "in" <+> pretty e
141 ]
143 Case e pats ->
144 P.hang pexpr 2 (P.vcat (map pretty' pats))
145 where
146 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
147 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
149 Data "::" [hd,tl] ->
150 pretty hd <+> P.text "::" <+> pretty tl
152 Data "[]" [] ->
153 P.text "[]"
155 Data name es
156 | Help.isTuple name ->
157 P.parens (commaCat (map pretty es))
158 | otherwise ->
159 P.hang (P.text name) 2 (P.sep (map prettyParens es))
161 Access e x ->
162 prettyParens e <> P.text "." <> variable x
164 Remove e x ->
165 P.braces (pretty e <+> P.text "-" <+> variable x)
167 Insert (Annotation.A _ (Remove e y)) x v ->
168 P.braces $
169 P.hsep
170 [ pretty e, P.text "-", variable y, P.text "|"
171 , variable x, P.equals, pretty v
172 ]
174 Insert e x v ->
175 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
177 Modify e fs ->
178 P.braces $
179 P.hang
180 (pretty e <+> P.text "|")
181 4
182 (commaSep $ map field fs)
183 where
184 field (k,v) = variable k <+> P.text "<-" <+> pretty v
186 Record fs ->
187 P.sep
188 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fs))
189 , P.rbrace
190 ]
191 where
192 field (name, value) =
193 variable name <+> P.equals <+> pretty value
195 GLShader _ _ _ ->
196 P.text "[glsl| ... |]"
198 Input name _ ->
199 P.text ("<input:" ++ name ++ ">")
201 Output name _ _ ->
202 P.text ("<output:" ++ name ++ ">")
204 Loopback name _ _ ->
205 P.text ("<loopback:" ++ name ++ ">")
208collectApps :: Expr ann def var -> [Expr ann def var]
209collectApps annExpr@(Annotation.A _ expr) =
210 case expr of
211 App a b -> collectApps a ++ [b]
212 _ -> [annExpr]
215collectLambdas :: Expr ann def var -> ([Pattern.Pattern var], Expr ann def var)
216collectLambdas lexpr@(Annotation.A _ expr) =
217 case expr of
218 Lambda pattern body ->
219 let (ps, body') = collectLambdas body
220 in (pattern : ps, body')
222 _ -> ([], lexpr)
225prettyParens :: (Pretty def, Pretty var, Var.ToString var) => Expr ann def var -> Doc
226prettyParens (Annotation.A _ expr) =
227 parensIf needed (pretty expr)
228 where
229 needed =
230 case expr of
231 Binop _ _ _ -> True
232 Lambda _ _ -> True
233 App _ _ -> True
234 MultiIf _ -> True
235 Let _ _ -> True
236 Case _ _ -> True
237 Data name (_:_) -> not (name == "::" || Help.isTuple name)
238 _ -> False