git.iko.soy/elk
on cfaeff9 help sign in
elk/src/AST/Expression/General.hs
218 lines 7.1 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
21---- GENERAL AST ----
23{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
24"type holes" that allow us to enrich the AST with additional information as we
25move through the compilation process. The type holes are used to represent:
27 ann: Annotations for arbitrary expressions. Allows you to add information
28 to the AST like position in source code or inferred types.
30 def: Definition style. The source syntax separates type annotations and
31 definitions, but after parsing we check that they are well formed and
32 collapse them.
34 var: Representation of variables. Starts as strings, but is later enriched
35 with information about what module a variable came from.
37-}
38type Expr annotation definition variable =
39 Annotation.Annotated annotation (Expr' annotation definition variable)
41data Expr' ann def var
42 = Literal Literal.Literal
43 | Var var
44 | Range (Expr ann def var) (Expr ann def var)
45 | ExplicitList [Expr ann def var]
46 | Binop var (Expr ann def var) (Expr ann def var)
47 | Lambda (Pattern.Pattern var) (Expr ann def var)
48 | App (Expr ann def var) (Expr ann def var)
49 | MultiIf [(Expr ann def var,Expr ann def var)]
50 | Let [def] (Expr ann def var)
51 | Case (Expr ann def var) [(Pattern.Pattern var, Expr ann def var)]
52 | Data String [Expr ann def var]
53 | Access (Expr ann def var) String
54 | Remove (Expr ann def var) String
55 | Insert (Expr ann def var) String (Expr ann def var)
56 | Modify (Expr ann def var) [(String, Expr ann def var)]
57 | Record [(String, Expr ann def var)]
58 -- for type checking and code gen only
59 | PortIn String (Type var)
60 | PortOut String (Type var) (Expr ann def var)
61 | GLShader String String Literal.GLShaderTipe
62 deriving (Show)
65---- UTILITIES ----
67rawVar :: String -> Expr' ann def Var.Raw
68rawVar x = Var (Var.Raw x)
70localVar :: String -> Expr' ann def Var.Canonical
71localVar x = Var (Var.Canonical Var.Local x)
73tuple :: [Expr ann def var] -> Expr' ann def var
74tuple es = Data ("_Tuple" ++ show (length es)) es
76delist :: Expr ann def var -> [Expr ann def var]
77delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
78delist _ = []
80saveEnvName :: String
81saveEnvName = "_save_the_environment!!!"
83dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical
84dummyLet defs =
85 Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName))
87instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where
88 pretty expr =
89 case expr of
90 Literal lit ->
91 pretty lit
93 Var x ->
94 pretty x
96 Range e1 e2 ->
97 P.brackets (pretty e1 <> P.text ".." <> pretty e2)
99 ExplicitList es ->
100 P.brackets (commaCat (map pretty es))
102 Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) e
103 | Var.toString op == "-" ->
104 P.text "-" <> prettyParens e
106 Binop op e1 e2 ->
107 P.hang (prettyParens e1) 2 (P.text op'' <+> prettyParens e2)
108 where
109 op' = Var.toString op
110 op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
112 Lambda p e ->
113 P.text "\\" <> args <+> P.text "->" <+> pretty body
114 where
115 (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)
116 args = P.sep (map Pattern.prettyParens ps)
118 App _ _ ->
119 P.hang func 2 (P.sep args)
120 where
121 func:args =
122 map prettyParens (collectApps (Annotation.A undefined expr))
124 MultiIf branches ->
125 P.text "if" $$ nest 3 (vcat $ map iff branches)
126 where
127 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
129 Let defs e ->
130 P.sep
131 [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
132 , P.text "in" <+> pretty e
133 ]
135 Case e pats ->
136 P.hang pexpr 2 (P.vcat (map pretty' pats))
137 where
138 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
139 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
141 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
142 Data "[]" [] -> P.text "[]"
143 Data name es
144 | Help.isTuple name -> P.parens (commaCat (map pretty es))
145 | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
147 Access e x ->
148 prettyParens e <> P.text "." <> variable x
150 Remove e x ->
151 P.braces (pretty e <+> P.text "-" <+> variable x)
153 Insert (Annotation.A _ (Remove e y)) x v ->
154 P.braces $
155 P.hsep
156 [ pretty e, P.text "-", variable y, P.text "|"
157 , variable x, P.equals, pretty v
158 ]
160 Insert e x v ->
161 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
163 Modify e fs ->
164 P.braces $
165 P.hang
166 (pretty e <+> P.text "|")
167 4
168 (commaSep $ map field fs)
169 where
170 field (k,v) = variable k <+> P.text "<-" <+> pretty v
172 Record fs ->
173 P.sep
174 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fs))
175 , P.rbrace
176 ]
177 where
178 field (field, value) =
179 variable field <+> P.equals <+> pretty value
181 GLShader _ _ _ -> P.text "[glsl| ... |]"
183 PortIn name _ -> P.text $ "<port:" ++ name ++ ">"
185 PortOut _ _ signal -> pretty signal
188collectApps :: Expr ann def var -> [Expr ann def var]
189collectApps annExpr@(Annotation.A _ expr) =
190 case expr of
191 App a b -> collectApps a ++ [b]
192 _ -> [annExpr]
195collectLambdas :: Expr ann def var -> ([Pattern.Pattern var], Expr ann def var)
196collectLambdas lexpr@(Annotation.A _ expr) =
197 case expr of
198 Lambda pattern body ->
199 let (ps, body') = collectLambdas body
200 in (pattern : ps, body')
202 _ -> ([], lexpr)
205prettyParens :: (Pretty def, Pretty var, Var.ToString var) => Expr ann def var -> Doc
206prettyParens (Annotation.A _ expr) =
207 parensIf needed (pretty expr)
208 where
209 needed =
210 case expr of
211 Binop _ _ _ -> True
212 Lambda _ _ -> True
213 App _ _ -> True
214 MultiIf _ -> True
215 Let _ _ -> True
216 Case _ _ -> True
217 Data name (_:_) -> not (name == "::" || Help.isTuple name)
218 _ -> False